--- /dev/null
+;; gnus-mule.el -- Provide multilingual environment to GNUS
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: gnus, mule
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; This package enables GNUS to code convert automatically
+;; accoding to a coding system specified for each news group.
+;; Please put the following line in your .emacs:
+;; (add-hook 'gnus-startup-hook 'gnus-mule-initialize)
+;; If you want to specify some coding system for a specific news
+;; group, add the fllowing line in your .emacs:
+;; (gnus-mule-add-group "xxx.yyy.zzz" 'some-coding-system)
+;;
+;; Decoding of summary buffer is not yet implemented.
+
+(require 'gnus)
+
+(defvar gnus-newsgroup-coding-systems nil
+ "Assoc list of news groups vs corresponding coding systems.
+Each element is a list of news group name and cons of coding systems
+for reading and posting.")
+
+;;;###autoload
+(defun gnus-mule-add-group (name coding-system)
+ "Specify that articles of news group NAME are encoded in CODING-SYSTEM.
+All news groups deeper than NAME are also the target.
+If CODING-SYSTEM is a cons, the car and cdr part are regarded as
+coding-system for reading and writing respectively."
+ (if (not (consp coding-system))
+ (setq coding-system (cons coding-system coding-system)))
+ (setq name (concat "^" (regexp-quote name)))
+ (let ((group (assoc name gnus-newsgroup-coding-systems)))
+ (if group
+ (setcdr group coding-system)
+ (setq gnus-newsgroup-coding-systems
+ (cons (cons name coding-system) gnus-newsgroup-coding-systems)))))
+
+(defun gnus-mule-get-coding-system (group)
+ "Return the coding system for news group GROUP."
+ (let ((groups gnus-newsgroup-coding-systems)
+ (len -1)
+ coding-system)
+ ;; Find an entry which matches GROUP the best (i.e. longest).
+ (while groups
+ (if (and (string-match (car (car groups)) group)
+ (> (match-end 0) len))
+ (setq len (match-end 0)
+ coding-system (cdr (car groups))))
+ (setq groups (cdr groups)))
+ coding-system))
+
+;; Flag to indicate if article buffer is already decoded or not.")
+(defvar gnus-mule-article-decoded nil)
+;; Codingsystem for reading articles of the current news group.
+(defvar gnus-mule-coding-system nil)
+(defvar gnus-mule-subject nil)
+(defvar gnus-mule-decoded-subject nil)
+(defvar gnus-mule-original-subject nil)
+
+;; Encode (if ENCODING is t) or decode (if ENCODING is nil) the
+;; region from START to END by CODING-SYSTEM.
+(defun gnus-mule-code-convert1 (start end coding-system encoding)
+ (if (< start end)
+ (save-excursion
+ (if encoding
+ (encode-coding-region start end coding-system)
+ (decode-coding-region start end coding-system)))))
+
+;; Encode (if ENCODING is t) or decode (if ENCODING is nil) the
+;; current buffer by CODING-SYSTEM. Try not to move positions of
+;; (window-start) and (point).
+(defun gnus-mule-code-convert (coding-system encoding)
+ (if coding-system
+ (let ((win (get-buffer-window (current-buffer))))
+ (if win
+ ;; We should keep (point) and (window-start).
+ (save-window-excursion
+ (select-window win)
+ (if encoding
+ ;; Simple way to assure point is on valid character boundary.
+ (beginning-of-line))
+ (gnus-mule-code-convert1 (point-min) (window-start)
+ coding-system encoding)
+ (gnus-mule-code-convert1 (window-start) (point)
+ coding-system encoding)
+ (gnus-mule-code-convert1 (point) (point-max)
+ coding-system encoding)
+ (if (not (pos-visible-in-window-p))
+ ;; point went out of window, move to the bottom of window.
+ (move-to-window-line -1)))
+ ;; No window for the buffer, no need to worry about (point)
+ ;; and (windos-start).
+ (gnus-mule-code-convert1 (point-min) (point-max)
+ coding-system encoding))
+ )))
+
+;; Set `gnus-mule-coding-system' to the coding system articles of the
+;; current news group is encoded. This function is set in
+;; `gnus-select-group-hook'.
+(defun gnus-mule-select-coding-system ()
+ (let ((coding-system (gnus-mule-get-coding-system gnus-newsgroup-name)))
+ (setq gnus-mule-coding-system
+ (if (and coding-system (coding-system-p (car coding-system)))
+ (car coding-system)))))
+
+;; Decode the current article. This function is set in
+;; `gnus-article-prepare-hook'.
+(defun gnus-mule-decode-article ()
+ (gnus-mule-code-convert gnus-mule-coding-system nil)
+ (setq gnus-mule-article-decoded t))
+
+;; Decode the current summary buffer. This function is set in
+;; `gnus-summary-prepare-hook'.
+(defun gnus-mule-decode-summary ()
+ ;; I have not yet implemented this function because I'm not yet
+ ;; familiar with the new Gnus codes, especialy how to extract only
+ ;; subjects from a summary buffer.
+ nil)
+
+(defun gnus-mule-toggle-article-format ()
+ "Toggle decoding/encoding of the current article buffer."
+ (interactive)
+ (let ((buf (get-buffer gnus-article-buffer)))
+ (if (and gnus-mule-coding-system buf)
+ (save-excursion
+ (set-buffer buf)
+ (let ((modif (buffer-modified-p))
+ buffer-read-only)
+ (gnus-mule-code-convert gnus-mule-coding-system
+ gnus-mule-article-decoded)
+ (setq gnus-mule-article-decoded (not gnus-mule-article-decoded))
+ (set-buffer-modified-p modif))))))
+
+;;;###autoload
+(defun gnus-mule-initialize ()
+ "Do several settings for GNUS to enable automatic code conversion."
+ ;; Convenient key definitions
+ (define-key gnus-article-mode-map "z" 'gnus-mule-toggle-article-format)
+ (define-key gnus-summary-mode-map "z" 'gnus-mule-toggle-article-format)
+ ;; Hook definition
+ (add-hook 'gnus-select-group-hook 'gnus-mule-select-coding-system)
+ (add-hook 'gnus-summary-prepare-hook 'gnus-mule-decode-summary)
+ (add-hook 'gnus-article-prepare-hook 'gnus-mule-decode-article))
+
+(gnus-mule-add-group "" 'coding-system-iso-2022-7) ;; default coding system
+(gnus-mule-add-group "alt" 'no-conversion)
+(gnus-mule-add-group "comp" 'no-conversion)
+(gnus-mule-add-group "gnu" 'no-conversion)
+(gnus-mule-add-group "rec" 'no-conversion)
+(gnus-mule-add-group "sci" 'no-conversion)
+(gnus-mule-add-group "soc" 'no-conversion)
+(gnus-mule-add-group "alt.chinese.text" 'coding-system-hz)
+(gnus-mule-add-group "alt.hk" 'coding-system-hz)
+(gnus-mule-add-group "alt.chinese.text.big5" 'coding-system-big5)
+(gnus-mule-add-group "soc.culture.vietnamese" '(nil . coding-system-viqr))
+
+(add-hook 'gnus-startup-hook 'gnus-mule-initialize)
+
+;; gnus-mule.el ends here
--- /dev/null
+;; ccl.el -- CCL (Code Conversion Language) compiler
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: CCL, mule, multilingual, character set, coding-system
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; CCL (Code Conversion Language) is a simple programming language to
+;; be used for various kind of code conversion. CCL program is
+;; compiled to CCL code (vector of integers) and executed by CCL
+;; interpreter of Emacs.
+;;
+;; CCL is used for code conversion at process I/O and file I/O for
+;; non-standard coding-system. In addition, it is used for
+;; calculating a code point of X's font from a character code.
+;; However, since CCL is designed as a powerful programming language,
+;; it can be used for more generic calculation. For instance,
+;; combination of three or more arithmetic operations can be
+;; calculated faster than Emacs Lisp.
+;;
+;; Here's the syntax of CCL program in BNF notation.
+;;
+;; CCL_PROGRAM :=
+;; (BUFFER_MAGNIFICATION
+;; CCL_MAIN_BLOCK
+;; [ CCL_EOF_BLOCK ])
+;;
+;; BUFFER_MAGNIFICATION := integer
+;; CCL_MAIN_BLOCK := CCL_BLOCK
+;; CCL_EOF_BLOCK := CCL_BLOCK
+;;
+;; CCL_BLOCK :=
+;; STATEMENT | (STATEMENT [STATEMENT ...])
+;; STATEMENT :=
+;; SET | IF | BRANCH | LOOP | REPEAT | BREAK | READ | WRITE | CALL
+;;
+;; SET :=
+;; (REG = EXPRESSION)
+;; | (REG ASSIGNMENT_OPERATOR EXPRESSION)
+;; | integer
+;;
+;; EXPRESSION := ARG | (EXPRESSION OPERATOR ARG)
+;;
+;; IF := (if EXPRESSION CCL_BLOCK CCL_BLOCK)
+;; BRANCH := (branch EXPRESSION CCL_BLOCK [CCL_BLOCK ...])
+;; LOOP := (loop STATEMENT [STATEMENT ...])
+;; BREAK := (break)
+;; REPEAT :=
+;; (repeat)
+;; | (write-repeat [REG | integer | string])
+;; | (write-read-repeat REG [integer | ARRAY])
+;; READ :=
+;; (read REG ...)
+;; | (read-if (REG OPERATOR ARG) CCL_BLOCK CCL_BLOCK)
+;; | (read-branch REG CCL_BLOCK [CCL_BLOCK ...])
+;; WRITE :=
+;; (write REG ...)
+;; | (write EXPRESSION)
+;; | (write integer) | (write string) | (write REG ARRAY)
+;; | string
+;; CALL := (call ccl-program-name)
+;; END := (end)
+;;
+;; REG := r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7
+;; ARG := REG | integer
+;; OPERATOR :=
+;; + | - | * | / | % | & | '|' | ^ | << | >> | <8 | >8 | //
+;; | < | > | == | <= | >= | != | de-sjis | en-sjis
+;; ASSIGNMENT_OPERATOR :=
+;; += | -= | *= | /= | %= | &= | '|=' | ^= | <<= | >>=
+;; ARRAY := '[' interger ... ']'
+
+;;; Code:
+
+(defconst ccl-command-table
+ [if branch loop break repeat write-repeat write-read-repeat
+ read read-if read-branch write call end]
+ "*Vector of CCL commands (symbols).")
+
+;; Put a property to each symbol of CCL commands for the compiler.
+(let (op (i 0) (len (length ccl-command-table)))
+ (while (< i len)
+ (setq op (aref ccl-command-table i))
+ (put op 'ccl-compile-function (intern (format "ccl-compile-%s" op)))
+ (setq i (1+ i))))
+
+(defconst ccl-code-table
+ [set-register
+ set-short-const
+ set-const
+ set-array
+ jump
+ jump-cond
+ write-register-jump
+ write-register-read-jump
+ write-const-jump
+ write-const-read-jump
+ write-string-jump
+ write-array-read-jump
+ read-jump
+ branch
+ read-register
+ write-expr-const
+ read-branch
+ write-register
+ write-expr-register
+ call
+ write-const-string
+ write-array
+ end
+ set-assign-expr-const
+ set-assign-expr-register
+ set-expr-const
+ set-expr-register
+ jump-cond-expr-const
+ jump-cond-expr-register
+ read-jump-cond-expr-const
+ read-jump-cond-expr-register
+ ]
+ "*Vector of CCL compiled codes (symbols).")
+
+;; Put a property to each symbol of CCL codes for the disassembler.
+(let (code (i 0) (len (length ccl-code-table)))
+ (while (< i len)
+ (setq code (aref ccl-code-table i))
+ (put code 'ccl-code i)
+ (put code 'ccl-dump-function (intern (format "ccl-dump-%s" code)))
+ (setq i (1+ i))))
+
+(defconst ccl-jump-code-list
+ '(jump jump-cond write-register-jump write-register-read-jump
+ write-const-jump write-const-read-jump write-string-jump
+ write-array-read-jump read-jump))
+
+;; Put a property `jump-flag' to each CCL code which execute jump in
+;; some way.
+(let ((l ccl-jump-code-list))
+ (while l
+ (put (car l) 'jump-flag t)
+ (setq l (cdr l))))
+
+(defconst ccl-register-table
+ [r0 r1 r2 r3 r4 r5 r6 r7]
+ "*Vector of CCL registers (symbols).")
+
+;; Put a property to indicate register number to each symbol of CCL.
+;; registers.
+(let (reg (i 0) (len (length ccl-register-table)))
+ (while (< i len)
+ (setq reg (aref ccl-register-table i))
+ (put reg 'ccl-register-number i)
+ (setq i (1+ i))))
+
+(defconst ccl-arith-table
+ [+ - * / % & | ^ << >> <8 >8 // nil nil nil
+ < > == <= >= != de-sjis en-sjis]
+ "*Vector of CCL arithmetic/logical operators (symbols).")
+
+;; Put a property to each symbol of CCL operators for the compiler.
+(let (arith (i 0) (len (length ccl-arith-table)))
+ (while (< i len)
+ (setq arith (aref ccl-arith-table i))
+ (if arith (put arith 'ccl-arith-code i))
+ (setq i (1+ i))))
+
+(defconst ccl-assign-arith-table
+ [+= -= *= /= %= &= |= ^= <<= >>= <8= >8= //=]
+ "*Vector of CCL assignment operators (symbols).")
+
+;; Put a property to each symbol of CCL assignment operators for the compiler.
+(let (arith (i 0) (len (length ccl-assign-arith-table)))
+ (while (< i len)
+ (setq arith (aref ccl-assign-arith-table i))
+ (put arith 'ccl-self-arith-code i)
+ (setq i (1+ i))))
+
+(defvar ccl-program-vector nil
+ "Working vector of CCL codes produced by CCL compiler.")
+(defvar ccl-current-ic 0
+ "The current index for `ccl-program-vector'.")
+
+;; Embed integer DATA in `ccl-program-vector' at `ccl-current-ic' and
+;; increment it. If IC is specified, embed DATA at IC.
+(defun ccl-embed-data (data &optional ic)
+ (if ic
+ (aset ccl-program-vector ic data)
+ (aset ccl-program-vector ccl-current-ic data)
+ (setq ccl-current-ic (1+ ccl-current-ic))))
+
+;; Embed string STR of length LEN in `ccl-program-vector' at
+;; `ccl-current-ic'.
+(defun ccl-embed-string (len str)
+ (let ((i 0))
+ (while (< i len)
+ (ccl-embed-data (logior (ash (aref str i) 16)
+ (if (< (1+ i) len)
+ (ash (aref str (1+ i)) 8)
+ 0)
+ (if (< (+ i 2) len)
+ (aref str (+ i 2))
+ 0)))
+ (setq i (+ i 3)))))
+
+;; Embed a relative jump address to `ccl-current-ic' in
+;; `ccl-program-vector' at IC without altering the other bit field.
+(defun ccl-embed-current-address (ic)
+ (let ((relative (- ccl-current-ic (1+ ic))))
+ (aset ccl-program-vector ic
+ (logior (aref ccl-program-vector ic) (ash relative 8)))))
+
+;; Embed CCL code for the operation OP and arguments REG and DATA in
+;; `ccl-program-vector' at `ccl-current-ic' in the following format.
+;; |----------------- integer (28-bit) ------------------|
+;; |------------ 20-bit ------------|- 3-bit --|- 5-bit -|
+;; |------------- DATA -------------|-- REG ---|-- OP ---|
+;; If REG2 is specified, embed a code in the following format.
+;; |------- 17-bit ------|- 3-bit --|- 3-bit --|- 5-bit -|
+;; |-------- DATA -------|-- REG2 --|-- REG ---|-- OP ---|
+
+;; If REG is a CCL register symbol (e.g. r0, r1...), the register
+;; number is embedded. If OP is one of unconditional jumps, DATA is
+;; changed to an absolute jump address.
+
+(defun ccl-embed-code (op reg data &optional reg2)
+ (if (and (> data 0) (get op 'jump-flag))
+ ;; DATA is an absolute jump address. Make it relative to the
+ ;; next of jump code.
+ (setq data (- data (1+ ccl-current-ic))))
+ (let ((code (logior (get op 'ccl-code)
+ (ash
+ (if (symbolp reg) (get reg 'ccl-register-number) reg) 5)
+ (if reg2
+ (logior (ash (get reg2 'ccl-register-number) 8)
+ (ash data 11))
+ (ash data 8)))))
+ (aset ccl-program-vector ccl-current-ic code)
+ (setq ccl-current-ic (1+ ccl-current-ic))))
+
+;; Just advance `ccl-current-ic' by INC.
+(defun ccl-increment-ic (inc)
+ (setq ccl-current-ic (+ ccl-current-ic inc)))
+
+;;;###autoload
+(defun ccl-program-p (obj)
+ "T if OBJECT is a valid CCL compiled code."
+ (and (vectorp obj)
+ (let ((i 0) (len (length obj)) (flag t))
+ (if (> len 1)
+ (progn
+ (while (and flag (< i len))
+ (setq flag (integerp (aref obj i)))
+ (setq i (1+ i)))
+ flag)))))
+
+;; If non-nil, index of the start of the current loop.
+(defvar ccl-loop-head nil)
+;; If non-nil, list of absolute addresses of the breaking points of
+;; the current loop.
+(defvar ccl-breaks nil)
+
+;;;###autoload
+(defun ccl-compile (ccl-program)
+ "Return a comiled code of CCL-PROGRAM as a vector of integer."
+ (if (or (null (consp ccl-program))
+ (null (integerp (car ccl-program)))
+ (null (listp (car (cdr ccl-program)))))
+ (error "CCL: Invalid CCL program: %s" ccl-program))
+ (if (null (vectorp ccl-program-vector))
+ (setq ccl-program-vector (make-vector 8192 0)))
+ (setq ccl-loop-head nil ccl-breaks nil)
+ (setq ccl-current-ic 0)
+
+ ;; The first element is the buffer magnification.
+ (ccl-embed-data (car ccl-program))
+
+ ;; The second element is the address of the start CCL code for
+ ;; processing end of input buffer (we call it eof-processor). We
+ ;; set it later.
+ (ccl-increment-ic 1)
+
+ ;; Compile the main body of the CCL program.
+ (ccl-compile-1 (car (cdr ccl-program)))
+
+ ;; Embed the address of eof-processor.
+ (ccl-embed-data ccl-current-ic 1)
+
+ ;; Then compile eof-processor.
+ (if (nth 2 ccl-program)
+ (ccl-compile-1 (nth 2 ccl-program)))
+
+ ;; At last, embed termination code.
+ (ccl-embed-code 'end 0 0)
+
+ (let ((vec (make-vector ccl-current-ic 0))
+ (i 0))
+ (while (< i ccl-current-ic)
+ (aset vec i (aref ccl-program-vector i))
+ (setq i (1+ i)))
+ vec))
+
+;; Signal syntax error.
+(defun ccl-syntax-error (cmd)
+ (error "CCL: Syntax error: %s" cmd))
+
+;; Check if ARG is a valid CCL register.
+(defun ccl-check-register (arg cmd)
+ (if (get arg 'ccl-register-number)
+ arg
+ (error "CCL: Invalid register %s in %s." arg cmd)))
+
+;; Check if ARG is a valid CCL command.
+(defun ccl-check-compile-function (arg cmd)
+ (or (get arg 'ccl-compile-function)
+ (error "CCL: Invalid command: %s" cmd)))
+
+;; In the following code, most ccl-compile-XXXX functions return t if
+;; they end with unconditional jump, else return nil.
+
+;; Compile CCL-BLOCK (see the syntax above).
+(defun ccl-compile-1 (ccl-block)
+ (let (unconditional-jump
+ cmd)
+ (if (or (integerp ccl-block)
+ (stringp ccl-block)
+ (and ccl-block (symbolp (car ccl-block))))
+ ;; This block consists of single statement.
+ (setq ccl-block (list ccl-block)))
+
+ ;; Now CCL-BLOCK is a list of statements. Compile them one by
+ ;; one.
+ (while ccl-block
+ (setq cmd (car ccl-block))
+ (setq unconditional-jump
+ (cond ((integerp cmd)
+ ;; SET statement for the register 0.
+ (ccl-compile-set (list 'r0 '= cmd)))
+
+ ((stringp cmd)
+ ;; WRITE statement of string argument.
+ (ccl-compile-write-string cmd))
+
+ ((listp cmd)
+ ;; The other statements.
+ (cond ((eq (nth 1 cmd) '=)
+ ;; SET statement of the form `(REG = EXPRESSION)'.
+ (ccl-compile-set cmd))
+
+ ((and (symbolp (nth 1 cmd))
+ (get (nth 1 cmd) 'ccl-self-arith-code))
+ ;; SET statement with an assignment operation.
+ (ccl-compile-self-set cmd))
+
+ (t
+ (funcall (ccl-check-compile-function (car cmd) cmd)
+ cmd))))
+
+ (t
+ (ccl-syntax-error cmd))))
+ (setq ccl-block (cdr ccl-block)))
+ unconditional-jump))
+
+(defconst ccl-max-short-const (ash 1 19))
+(defconst ccl-min-short-const (ash -1 19))
+
+;; Compile SET statement.
+(defun ccl-compile-set (cmd)
+ (let ((rrr (ccl-check-register (car cmd) cmd))
+ (right (nth 2 cmd)))
+ (cond ((listp right)
+ ;; CMD has the form `(RRR = (XXX OP YYY))'.
+ (ccl-compile-expression rrr right))
+
+ ((integerp right)
+ ;; CMD has the form `(RRR = integer)'.
+ (if (and (<= right ccl-max-short-const)
+ (>= right ccl-min-short-const))
+ (ccl-embed-code 'set-short-const rrr right)
+ (ccl-embed-code 'set-const rrr 0)
+ (ccl-embed-data right)))
+
+ (t
+ ;; CMD has the form `(RRR = rrr [ array ])'.
+ (ccl-check-register right cmd)
+ (let ((ary (nth 3 cmd)))
+ (if (vectorp ary)
+ (let ((i 0) (len (length ary)))
+ (ccl-embed-code 'set-array rrr len right)
+ (while (< i len)
+ (ccl-embed-data (aref ary i))
+ (setq i (1+ i))))
+ (ccl-embed-code 'set-register rrr 0 right))))))
+ nil)
+
+;; Compile SET statement with ASSIGNMENT_OPERATOR.
+(defun ccl-compile-self-set (cmd)
+ (let ((rrr (ccl-check-register (car cmd) cmd))
+ (right (nth 2 cmd)))
+ (if (listp right)
+ ;; CMD has the form `(RRR ASSIGN_OP (XXX OP YYY))', compile
+ ;; the right hand part as `(r7 = (XXX OP YYY))' (note: the
+ ;; register 7 can be used for storing temporary value).
+ (progn
+ (ccl-compile-expression 'r7 right)
+ (setq right 'r7)))
+ ;; Now CMD has the form `(RRR ASSIGN_OP ARG)'. Compile it as
+ ;; `(RRR = (RRR OP ARG))'.
+ (ccl-compile-expression
+ rrr
+ (list rrr (intern (substring (symbol-name (nth 1 cmd)) 0 -1)) right)))
+ nil)
+
+;; Compile SET statement of the form `(RRR = EXPR)'.
+(defun ccl-compile-expression (rrr expr)
+ (let ((left (car expr))
+ (op (get (nth 1 expr) 'ccl-arith-code))
+ (right (nth 2 expr)))
+ (if (listp left)
+ (progn
+ ;; EXPR has the form `((EXPR2 OP2 ARG) OP RIGHT)'. Compile
+ ;; the first term as `(r7 = (EXPR2 OP2 ARG)).'
+ (ccl-compile-expression 'r7 left)
+ (setq left 'r7)))
+
+ ;; Now EXPR has the form (LEFT OP RIGHT).
+ (if (eq rrr left)
+ ;; Compile this SET statement as `(RRR OP= RIGHT)'.
+ (if (integerp right)
+ (progn
+ (ccl-embed-code 'set-assign-expr-const rrr (ash op 3) 'r0)
+ (ccl-embed-data right))
+ (ccl-check-register right expr)
+ (ccl-embed-code 'set-assign-expr-register rrr (ash op 3) right))
+
+ ;; Compile this SET statement as `(RRR = (LEFT OP RIGHT))'.
+ (if (integerp right)
+ (progn
+ (ccl-embed-code 'set-expr-const rrr (ash op 3) left)
+ (ccl-embed-data right))
+ (ccl-check-register right expr)
+ (ccl-embed-code 'set-expr-register
+ rrr
+ (logior (ash op 3) (get right 'ccl-register-number))
+ left)))))
+
+;; Compile WRITE statement with string argument.
+(defun ccl-compile-write-string (str)
+ (let ((len (length str)))
+ (ccl-embed-code 'write-const-string 1 len)
+ (ccl-embed-string len str))
+ nil)
+
+;; Compile IF statement of the form `(if CONDITION TRUE-PART FALSE-PART)'.
+;; If READ-FLAG is non-nil, this statement has the form
+;; `(read-if (REG OPERATOR ARG) TRUE-PART FALSE-PART)'.
+(defun ccl-compile-if (cmd &optional read-flag)
+ (if (and (/= (length cmd) 3) (/= (length cmd) 4))
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let ((condition (nth 1 cmd))
+ (true-cmds (nth 2 cmd))
+ (false-cmds (nth 3 cmd))
+ jump-cond-address
+ false-ic)
+ (if (and (listp condition)
+ (listp (car condition)))
+ ;; If CONDITION is a nested expression, the inner expression
+ ;; should be compiled at first as SET statement, i.e.:
+ ;; `(if ((X OP2 Y) OP Z) ...)' is compiled into two statements:
+ ;; `(r7 = (X OP2 Y)) (if (r7 OP Z) ...)'.
+ (progn
+ (ccl-compile-expression 'r7 (car condition))
+ (setq condition (cons 'r7 (cdr condition)))
+ (setq cmd (cons (car cmd)
+ (cons condition (cdr (cdr cmd)))))))
+
+ (setq jump-cond-address ccl-current-ic)
+ ;; Compile CONDITION.
+ (if (symbolp condition)
+ ;; CONDITION is a register.
+ (progn
+ (ccl-check-register condition cmd)
+ (ccl-embed-code 'jump-cond condition 0))
+ ;; CONDITION is a simple expression of the form (RRR OP ARG).
+ (let ((rrr (car condition))
+ (op (get (nth 1 condition) 'ccl-arith-code))
+ (arg (nth 2 condition)))
+ (ccl-check-register rrr cmd)
+ (if (integerp arg)
+ (progn
+ (ccl-embed-code (if read-flag 'read-jump-cond-expr-const
+ 'jump-cond-expr-const)
+ rrr 0)
+ (ccl-embed-data op)
+ (ccl-embed-data arg))
+ (ccl-check-register arg cmd)
+ (ccl-embed-code (if read-flag 'read-jump-cond-expr-register
+ 'jump-cond-expr-register)
+ rrr 0)
+ (ccl-embed-data op)
+ (ccl-embed-data (get arg 'ccl-register-number)))))
+
+ ;; Compile TRUE-PART.
+ (let ((unconditional-jump (ccl-compile-1 true-cmds)))
+ (if (null false-cmds)
+ ;; This is the place to jump to if condition is false.
+ (ccl-embed-current-address jump-cond-address)
+ (let (end-true-part-address)
+ (if (not unconditional-jump)
+ (progn
+ ;; If TRUE-PART does not end with unconditional jump, we
+ ;; have to jump to the end of FALSE-PART from here.
+ (setq end-true-part-address ccl-current-ic)
+ (ccl-embed-code 'jump 0 0)))
+ ;; This is the place to jump to if CONDITION is false.
+ (ccl-embed-current-address jump-cond-address)
+ ;; Compile FALSE-PART.
+ (setq unconditional-jump
+ (and (ccl-compile-1 false-cmds) unconditional-jump))
+ (if end-true-part-address
+ ;; This is the place to jump to after the end of TRUE-PART.
+ (ccl-embed-current-address end-true-part-address))))
+ unconditional-jump)))
+
+;; Compile BRANCH statement.
+(defun ccl-compile-branch (cmd)
+ (if (< (length cmd) 3)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (ccl-compile-branch-blocks 'branch
+ (ccl-compile-branch-expression (nth 1 cmd) cmd)
+ (cdr (cdr cmd))))
+
+;; Compile READ statement of the form `(read-branch EXPR BLOCK0 BLOCK1 ...)'.
+(defun ccl-compile-read-branch (cmd)
+ (if (< (length cmd) 3)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (ccl-compile-branch-blocks 'read-branch
+ (ccl-compile-branch-expression (nth 1 cmd) cmd)
+ (cdr (cdr cmd))))
+
+;; Compile EXPRESSION part of BRANCH statement and return register
+;; which holds a value of the expression.
+(defun ccl-compile-branch-expression (expr cmd)
+ (if (listp expr)
+ ;; EXPR has the form `(EXPR2 OP ARG)'. Compile it as SET
+ ;; statement of the form `(r7 = (EXPR2 OP ARG))'.
+ (progn
+ (ccl-compile-expression 'r7 expr)
+ 'r7)
+ (ccl-check-register expr cmd)))
+
+;; Compile BLOCKs of BRANCH statement. CODE is 'branch or 'read-branch.
+;; REG is a register which holds a value of EXPRESSION part. BLOCKs
+;; is a list of CCL-BLOCKs.
+(defun ccl-compile-branch-blocks (code rrr blocks)
+ (let ((branches (length blocks))
+ branch-idx
+ jump-table-head-address
+ empty-block-indexes
+ block-tail-addresses
+ block-unconditional-jump)
+ (ccl-embed-code code rrr branches)
+ (setq jump-table-head-address ccl-current-ic)
+ ;; The size of jump table is the number of blocks plus 1 (for the
+ ;; case RRR is out of range).
+ (ccl-increment-ic (1+ branches))
+ (setq empty-block-indexes (list branches))
+ ;; Compile each block.
+ (setq branch-idx 0)
+ (while blocks
+ (if (null (car blocks))
+ ;; This block is empty.
+ (setq empty-block-indexes (cons branch-idx empty-block-indexes)
+ block-unconditional-jump t)
+ ;; This block is not empty.
+ (ccl-embed-data (- ccl-current-ic jump-table-head-address)
+ (+ jump-table-head-address branch-idx))
+ (setq block-unconditional-jump (ccl-compile-1 (car blocks)))
+ (if (not block-unconditional-jump)
+ (progn
+ ;; Jump address of the end of branches are embedded later.
+ ;; For the moment, just remember where to embed them.
+ (setq block-tail-addresses
+ (cons ccl-current-ic block-tail-addresses))
+ (ccl-embed-code 'jump 0 0))))
+ (setq branch-idx (1+ branch-idx))
+ (setq blocks (cdr blocks)))
+ (if (not block-unconditional-jump)
+ ;; We don't need jump code at the end of the last block.
+ (setq block-tail-addresses (cdr block-tail-addresses)
+ ccl-current-ic (1- ccl-current-ic)))
+ ;; Embed jump address at the tailing jump commands of blocks.
+ (while block-tail-addresses
+ (ccl-embed-current-address (car block-tail-addresses))
+ (setq block-tail-addresses (cdr block-tail-addresses)))
+ ;; For empty blocks, make entries in the jump table point directly here.
+ (while empty-block-indexes
+ (ccl-embed-data (- ccl-current-ic jump-table-head-address)
+ (+ jump-table-head-address (car empty-block-indexes)))
+ (setq empty-block-indexes (cdr empty-block-indexes))))
+ ;; Branch command ends by unconditional jump if RRR is out of range.
+ nil)
+
+;; Compile LOOP statement.
+(defun ccl-compile-loop (cmd)
+ (if (< (length cmd) 2)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let* ((ccl-loop-head ccl-current-ic)
+ (ccl-breaks nil)
+ unconditional-jump)
+ (setq cmd (cdr cmd))
+ (if cmd
+ (progn
+ (setq unconditional-jump t)
+ (while cmd
+ (setq unconditional-jump
+ (and (ccl-compile-1 (car cmd)) unconditional-jump))
+ (setq cmd (cdr cmd)))
+ (if (not ccl-breaks)
+ unconditional-jump
+ ;; Embed jump address for break statements encountered in
+ ;; this loop.
+ (while ccl-breaks
+ (ccl-embed-current-address (car ccl-breaks))
+ (setq ccl-breaks (cdr ccl-breaks))))
+ nil))))
+
+;; Compile BREAK statement.
+(defun ccl-compile-break (cmd)
+ (if (/= (length cmd) 1)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (if (null ccl-loop-head)
+ (error "CCL: No outer loop: %s" cmd))
+ (setq ccl-breaks (cons ccl-current-ic ccl-breaks))
+ (ccl-embed-code 'jump 0 0)
+ t)
+
+;; Compile REPEAT statement.
+(defun ccl-compile-repeat (cmd)
+ (if (/= (length cmd) 1)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (if (null ccl-loop-head)
+ (error "CCL: No outer loop: %s" cmd))
+ (ccl-embed-code 'jump 0 ccl-loop-head)
+ t)
+
+;; Compile WRITE-REPEAT statement.
+(defun ccl-compile-write-repeat (cmd)
+ (if (/= (length cmd) 2)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (if (null ccl-loop-head)
+ (error "CCL: No outer loop: %s" cmd))
+ (let ((arg (nth 1 cmd)))
+ (cond ((integerp arg)
+ (ccl-embed-code 'write-const-jump 0 ccl-loop-head)
+ (ccl-embed-data arg))
+ ((stringp arg)
+ (let ((len (length arg))
+ (i 0))
+ (ccl-embed-code 'write-string-jump 0 ccl-loop-head)
+ (ccl-embed-data len)
+ (ccl-embed-string len arg)))
+ (t
+ (ccl-check-register arg cmd)
+ (ccl-embed-code 'write-register-jump arg ccl-loop-head))))
+ t)
+
+;; Compile WRITE-READ-REPEAT statement.
+(defun ccl-compile-write-read-repeat (cmd)
+ (if (or (< (length cmd) 2) (> (length cmd) 3))
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (if (null ccl-loop-head)
+ (error "CCL: No outer loop: %s" cmd))
+ (let ((rrr (ccl-check-register (nth 1 cmd) cmd))
+ (arg (nth 2 cmd)))
+ (cond ((null arg)
+ (ccl-embed-code 'write-register-read-jump rrr ccl-loop-head))
+ ((integerp arg)
+ (ccl-embed-code 'write-const-read-jump rrr arg ccl-loop-head))
+ ((vectorp arg)
+ (let ((len (length arg))
+ (i 0))
+ (ccl-embed-code 'write-array-read-jump rrr ccl-loop-head)
+ (ccl-embed-data len)
+ (while (< i len)
+ (ccl-embed-data (aref arg i))
+ (setq i (1+ i)))))
+ (t
+ (error "CCL: Invalid argument %s: %s" arg cmd)))
+ (ccl-embed-code 'read-jump rrr ccl-loop-head))
+ t)
+
+;; Compile READ statement.
+(defun ccl-compile-read (cmd)
+ (if (< (length cmd) 2)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let* ((args (cdr cmd))
+ (i (1- (length args))))
+ (while args
+ (let ((rrr (ccl-check-register (car args) cmd)))
+ (ccl-embed-code 'read-register rrr i)
+ (setq args (cdr args) i (1- i)))))
+ nil)
+
+;; Compile READ-IF statement.
+(defun ccl-compile-read-if (cmd)
+ (ccl-compile-if cmd 'read))
+
+;; Compile WRITE statement.
+(defun ccl-compile-write (cmd)
+ (if (< (length cmd) 2)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (let ((rrr (nth 1 cmd)))
+ (cond ((integerp rrr)
+ (ccl-embed-code 'write-const-string 0 rrr))
+ ((stringp rrr)
+ (ccl-compile-write-string rrr))
+ ((and (symbolp rrr) (vectorp (nth 2 cmd)))
+ (ccl-check-register rrr cmd)
+ ;; CMD has the form `(write REG ARRAY)'.
+ (let* ((arg (nth 2 cmd))
+ (len (length arg))
+ (i 0))
+ (ccl-embed-code 'write-array rrr len)
+ (while (< i len)
+ (if (not (integerp (aref arg i)))
+ (error "CCL: Invalid argument %s: %s" arg cmd))
+ (ccl-embed-data (aref arg i))
+ (setq i (1+ i)))))
+
+ ((symbolp rrr)
+ ;; CMD has the form `(write REG ...)'.
+ (let* ((args (cdr cmd))
+ (i (1- (length args))))
+ (while args
+ (setq rrr (ccl-check-register (car args) cmd))
+ (ccl-embed-code 'write-register rrr i)
+ (setq args (cdr args) i (1- i)))))
+
+ ((listp rrr)
+ ;; CMD has the form `(write (LEFT OP RIGHT))'.
+ (let ((left (car rrr))
+ (op (get (nth 1 rrr) 'ccl-arith-code))
+ (right (nth 2 rrr)))
+ (if (listp left)
+ (progn
+ ;; RRR has the form `((EXPR OP2 ARG) OP RIGHT)'.
+ ;; Compile the first term as `(r7 = (EXPR OP2 ARG))'.
+ (ccl-compile-expression 'r7 left)
+ (setq left 'r7)))
+ ;; Now RRR has the form `(ARG OP RIGHT)'.
+ (if (integerp right)
+ (progn
+ (ccl-embed-code 'write-expr-const 0 (ash op 3) left)
+ (ccl-embed-data right))
+ (ccl-check-register right rrr)
+ (ccl-embed-code 'write-expr-register 0
+ (logior (ash op 3)
+ (get right 'ccl-register-number))))))
+
+ (t
+ (error "CCL: Invalid argument: %s" cmd))))
+ nil)
+
+;; Compile CALL statement.
+(defun ccl-compile-call (cmd)
+ (if (/= (length cmd) 2)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (if (not (symbolp (nth 1 cmd)))
+ (error "CCL: Subroutine should be a symbol: %s" cmd))
+ (let* ((name (nth 1 cmd))
+ (idx (get name 'ccl-program-idx)))
+ (if (not idx)
+ (error "CCL: Unknown subroutine name: %s" name))
+ (ccl-embed-code 'call 0 idx))
+ nil)
+
+;; Compile END statement.
+(defun ccl-compile-end (cmd)
+ (if (/= (length cmd) 1)
+ (error "CCL: Invalid number of arguments: %s" cmd))
+ (ccl-embed-code 'end 0 0)
+ t)
+
+;;; CCL dump staffs
+
+;; To avoid byte-compiler warning.
+(defvar ccl-code)
+
+;;;###autoload
+(defun ccl-dump (ccl-code)
+ "Disassemble compiled CCL-CODE."
+ (let ((len (length ccl-code))
+ (buffer-mag (aref ccl-code 0)))
+ (cond ((= buffer-mag 0)
+ (insert "Don't output anything.\n"))
+ ((= buffer-mag 1)
+ (insert "Out-buffer must be as large as in-buffer.\n"))
+ (t
+ (insert
+ (format "Out-buffer must be %d times bigger than in-buffer.\n"
+ buffer-mag))))
+ (insert "Main-body:\n")
+ (setq ccl-current-ic 2)
+ (if (> (aref ccl-code 1) 0)
+ (progn
+ (while (< ccl-current-ic (aref ccl-code 1))
+ (ccl-dump-1))
+ (insert "At EOF:\n")))
+ (while (< ccl-current-ic len)
+ (ccl-dump-1))
+ ))
+
+;; Return a CCL code in `ccl-code' at `ccl-current-ic'.
+(defun ccl-get-next-code ()
+ (prog1
+ (aref ccl-code ccl-current-ic)
+ (setq ccl-current-ic (1+ ccl-current-ic))))
+
+(defun ccl-dump-1 ()
+ (let* ((code (ccl-get-next-code))
+ (cmd (aref ccl-code-table (logand code 31)))
+ (rrr (ash (logand code 255) -5))
+ (cc (ash code -8)))
+ (insert (format "%5d:[%s] " (1- ccl-current-ic) cmd))
+ (funcall (get cmd 'ccl-dump-function) rrr cc)))
+
+(defun ccl-dump-set-register (rrr cc)
+ (insert (format "r%d = r%d\n" rrr cc)))
+
+(defun ccl-dump-set-short-const (rrr cc)
+ (insert (format "r%d = %d\n" rrr cc)))
+
+(defun ccl-dump-set-const (rrr ignore)
+ (insert (format "r%d = %d\n" rrr (ccl-get-next-code))))
+
+(defun ccl-dump-set-array (rrr cc)
+ (let ((rrr2 (logand cc 7))
+ (len (ash cc -3))
+ (i 0))
+ (insert (format "r%d = array[r%d] of length %d\n\t"
+ rrr rrr2 len))
+ (while (< i len)
+ (insert (format "%d " (ccl-get-next-code)))
+ (setq i (1+ i)))
+ (insert "\n")))
+
+(defun ccl-dump-jump (ignore cc &optional address)
+ (insert (format "jump to %d(" (+ (or address ccl-current-ic) cc)))
+ (if (>= cc 0)
+ (insert "+"))
+ (insert (format "%d)\n" (1+ cc))))
+
+(defun ccl-dump-jump-cond (rrr cc)
+ (insert (format "if (r%d == 0), " rrr))
+ (ccl-dump-jump nil cc))
+
+(defun ccl-dump-write-register-jump (rrr cc)
+ (insert (format "write r%d, " rrr))
+ (ccl-dump-jump nil cc))
+
+(defun ccl-dump-write-register-read-jump (rrr cc)
+ (insert (format "write r%d, read r%d, " rrr rrr))
+ (ccl-dump-jump nil cc)
+ (ccl-get-next-code) ; Skip dummy READ-JUMP
+ )
+
+(defun ccl-extract-arith-op (cc)
+ (aref ccl-arith-table (ash cc -6)))
+
+(defun ccl-dump-write-expr-const (ignore cc)
+ (insert (format "write (r%d %s %d)\n"
+ (logand cc 7)
+ (ccl-extract-arith-op cc)
+ (ccl-get-next-code))))
+
+(defun ccl-dump-write-expr-register (ignore cc)
+ (insert (format "write (r%d %s r%d)\n"
+ (logand cc 7)
+ (ccl-extract-arith-op cc)
+ (logand (ash cc -3) 7))))
+
+(defun ccl-dump-insert-char (cc)
+ (cond ((= cc ?\t) (insert " \"^I\""))
+ ((= cc ?\n) (insert " \"^J\""))
+ (t (insert (format " \"%c\"" cc)))))
+
+(defun ccl-dump-write-const-jump (ignore cc)
+ (let ((address ccl-current-ic))
+ (insert "write char")
+ (ccl-dump-insert-char (ccl-get-next-code))
+ (insert ", ")
+ (ccl-dump-jump nil cc address)))
+
+(defun ccl-dump-write-const-read-jump (rrr cc)
+ (let ((address ccl-current-ic))
+ (insert "write char")
+ (ccl-dump-insert-char (ccl-get-next-code))
+ (insert (format ", read r%d, " rrr))
+ (ccl-dump-jump cc address)
+ (ccl-get-next-code) ; Skip dummy READ-JUMP
+ ))
+
+(defun ccl-dump-write-string-jump (ignore cc)
+ (let ((address ccl-current-ic)
+ (len (ccl-get-next-code))
+ (i 0))
+ (insert "write \"")
+ (while (< i len)
+ (let ((code (ccl-get-next-code)))
+ (insert (ash code -16))
+ (if (< (1+ i) len) (insert (logand (ash code -8) 255)))
+ (if (< (+ i 2) len) (insert (logand code 255))))
+ (setq i (+ i 3)))
+ (insert "\", ")
+ (ccl-dump-jump nil cc address)))
+
+(defun ccl-dump-write-array-read-jump (rrr cc)
+ (let ((address ccl-current-ic)
+ (len (ccl-get-next-code))
+ (i 0))
+ (insert (format "write array[r%d] of length %d,\n\t" rrr len))
+ (while (< i len)
+ (ccl-dump-insert-char (ccl-get-next-code))
+ (setq i (1+ i)))
+ (insert (format "\n\tthen read r%d, " rrr))
+ (ccl-dump-jump nil cc address)
+ (ccl-get-next-code) ; Skip dummy READ-JUMP.
+ ))
+
+(defun ccl-dump-read-jump (rrr cc)
+ (insert (format "read r%d, " rrr))
+ (ccl-dump-jump nil cc))
+
+(defun ccl-dump-branch (rrr len)
+ (let ((jump-table-head ccl-current-ic)
+ (i 0))
+ (insert (format "jump to array[r%d] of length %d\n\t" rrr len))
+ (while (<= i len)
+ (insert (format "%d " (+ jump-table-head (ccl-get-next-code))))
+ (setq i (1+ i)))
+ (insert "\n")))
+
+(defun ccl-dump-read-register (rrr cc)
+ (insert (format "read r%d (%d remaining)\n" rrr cc)))
+
+(defun ccl-dump-read-branch (rrr len)
+ (insert (format "read r%d, " rrr))
+ (ccl-dump-branch rrr len))
+
+(defun ccl-dump-write-register (rrr cc)
+ (insert (format "write r%d (%d remaining)\n" rrr cc)))
+
+(defun ccl-dump-call (ignore cc)
+ (insert (format "call subroutine #%d\n" cc)))
+
+(defun ccl-dump-write-const-string (rrr cc)
+ (if (= rrr 0)
+ (progn
+ (insert "write char")
+ (ccl-dump-insert-char cc)
+ (newline))
+ (let ((len cc)
+ (i 0))
+ (insert "write \"")
+ (while (< i len)
+ (let ((code (ccl-get-next-code)))
+ (insert (format "%c" (lsh code -16)))
+ (if (< (1+ i) len)
+ (insert (format "%c" (logand (lsh code -8) 255))))
+ (if (< (+ i 2) len)
+ (insert (format "%c" (logand code 255))))
+ (setq i (+ i 3))))
+ (insert "\"\n"))))
+
+(defun ccl-dump-write-array (rrr cc)
+ (let ((i 0))
+ (insert (format "write array[r%d] of length %d\n\t" rrr cc))
+ (while (< i cc)
+ (ccl-dump-insert-char (ccl-get-next-code))
+ (setq i (1+ i)))
+ (insert "\n")))
+
+(defun ccl-dump-end (&rest ignore)
+ (insert "end\n"))
+
+(defun ccl-dump-set-assign-expr-const (rrr cc)
+ (insert (format "r%d %s= %d\n"
+ rrr
+ (ccl-extract-arith-op cc)
+ (ccl-get-next-code))))
+
+(defun ccl-dump-set-assign-expr-register (rrr cc)
+ (insert (format "r%d %s= r%d\n"
+ rrr
+ (ccl-extract-arith-op cc)
+ (logand cc 7))))
+
+(defun ccl-dump-set-expr-const (rrr cc)
+ (insert (format "r%d = r%d %s %d\n"
+ rrr
+ (logand cc 7)
+ (ccl-extract-arith-op cc)
+ (ccl-get-next-code))))
+
+(defun ccl-dump-set-expr-register (rrr cc)
+ (insert (format "r%d = r%d %s r%d\n"
+ rrr
+ (logand cc 7)
+ (ccl-extract-arith-op cc)
+ (logand (ash cc -3) 7))))
+
+(defun ccl-dump-jump-cond-expr-const (rrr cc)
+ (let ((address ccl-current-ic))
+ (insert (format "if !(r%d %s %d), "
+ rrr
+ (aref ccl-arith-table (ccl-get-next-code))
+ (ccl-get-next-code)))
+ (ccl-dump-jump nil cc address)))
+
+(defun ccl-dump-jump-cond-expr-register (rrr cc)
+ (let ((address ccl-current-ic))
+ (insert (format "if !(r%d %s r%d), "
+ rrr
+ (aref ccl-arith-table (ccl-get-next-code))
+ (ccl-get-next-code)))
+ (ccl-dump-jump nil cc address)))
+
+(defun ccl-dump-read-jump-cond-expr-const (rrr cc)
+ (insert (format "read r%d, " rrr))
+ (ccl-dump-jump-cond-expr-const rrr cc))
+
+(defun ccl-dump-read-jump-cond-expr-register (rrr cc)
+ (insert (format "read r%d, " rrr))
+ (ccl-dump-jump-cond-expr-register rrr cc))
+
+(defun ccl-dump-binary (ccl-code)
+ (let ((len (length ccl-code))
+ (i 2))
+ (while (< i len)
+ (let ((code (aref ccl-code i))
+ (j 27))
+ (while (>= j 0)
+ (insert (if (= (logand code (ash 1 j)) 0) ?0 ?1))
+ (setq j (1- j)))
+ (setq code (logand code 31))
+ (if (< code (length ccl-code-table))
+ (insert (format ":%s" (aref ccl-code-table code))))
+ (insert "\n"))
+ (setq i (1+ i)))))
+
+;; CCL emulation staffs
+
+;; Not yet implemented.
+\f
+;;;###autoload
+(defmacro declare-ccl-program (name)
+ "Declare NAME as a name of CCL program.
+
+To compile a CCL program which calls another CCL program not yet
+defined, it must be declared as a CCL program in advance."
+ `(put ',name 'ccl-program-idx (register-ccl-program ',name nil)))
+
+;;;###autoload
+(defmacro define-ccl-program (name ccl-program &optional doc)
+ "Set NAME the compiled code of CCL-PROGRAM.
+CCL-PROGRAM is `eval'ed before being handed to the CCL compiler `ccl-compile'.
+The compiled code is a vector of integers."
+ `(let ((prog ,(ccl-compile (eval ccl-program))))
+ (defconst ,name prog ,doc)
+ (put ',name 'ccl-program-idx (register-ccl-program ',name prog))
+ nil))
+
+;;;###autoload
+(defun ccl-execute-with-args (ccl-prog &rest args)
+ "Execute CCL-PROGRAM with registers initialized by the remaining args.
+The return value is a vector of resulting CCL registeres."
+ (let ((reg (make-vector 8 0))
+ (i 0))
+ (while (and args (< i 8))
+ (if (not (integerp (car args)))
+ (error "Arguments should be integer"))
+ (aset reg i (car args))
+ (setq args (cdr args) i (1+ i)))
+ (ccl-execute ccl-prog reg)
+ reg))
+
+(provide 'ccl)
+
+;; ccl.el ends here
--- /dev/null
+;;; characters.el --- set syntax and category for multibyte characters
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: multibyte character, character set, syntax, category
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; This file contains multibyte characters. Save this file always in
+;; `coding-system-iso-2022-7'.
+
+;;; Predefined categories.
+
+;; For each character set.
+
+(define-category ?a "ASCII")
+(define-category ?l "Latin")
+(define-category ?t "Thai")
+(define-category ?g "Greek")
+(define-category ?b "Arabic")
+(define-category ?w "Hebrew")
+(define-category ?y "Cyrillic")
+(define-category ?k "Japanese katakana")
+(define-category ?r "Japanese roman")
+(define-category ?c "Chinese")
+(define-category ?j "Japanese")
+(define-category ?h "Korean")
+(define-category ?e "Ethiopic (Ge'ez)")
+(define-category ?v "Vietnamese")
+(define-category ?i "Indian")
+
+;; For each group (row) of 2-byte character sets.
+
+(define-category ?A "Alpha numeric characters of 2-byte character sets")
+(define-category ?C "Chinese (Han) characters of 2-byte character sets")
+(define-category ?G "Greek characters of 2-byte characters sets")
+(define-category ?H "Japanese Hiragana characters of 2-byte character sets")
+(define-category ?K "Japanese Katakana characters of 2-byte character sets")
+(define-category ?N "Korean Hangul characters of 2-byte character sets")
+(define-category ?Y "Cyrillic character of 2-byte character sets")
+(define-category ?I "Indian Glyphs")
+
+;; For phonetic classifications.
+
+(define-category ?0 "consonant")
+(define-category ?1 "base vowel")
+(define-category ?2 "upper diacritical mark (including upper vowel)")
+(define-category ?3 "lower diacritical mark (including lower vowel)")
+(define-category ?4 "tone mark")
+(define-category ?5 "vowel")
+(define-category ?6 "digit")
+(define-category ?7 "vowel-modifying diacritical mark")
+(define-category ?8 "vowel-signs.")
+
+;; For filling.
+(define-category ?| "While filling, we can break a line at this character.")
+
+;; Keep the followings for `kinsoku' processing. See comments in
+;; kinsoku.el.
+(define-category ?> "A character which can't be placed at beginning of line.")
+(define-category ?< "A character which can't be placed at end of line.")
+
+\f
+;;; Setting syntax and category.
+
+;; ASCII
+
+(let ((ch 32))
+ (while (< ch 127) ; All ASCII characters have
+ (modify-category-entry ch ?a) ; the category `a' (ASCII)
+ (modify-category-entry ch ?l) ; and `l' (Latin).
+ (setq ch (1+ ch))))
+
+;; Arabic character set
+
+(let ((charsets '(arabic-iso8859-6
+ arabic-digit
+ arabic-1-column
+ arabic-2-column)))
+ (while charsets
+ (modify-syntax-entry (make-char (car charsets)) "w")
+ (modify-category-entry (make-char (car charsets)) ?b)
+ (setq charsets (cdr charsets))))
+
+;; Chinese character set (GB2312)
+
+(modify-syntax-entry (make-char 'chinese-gb2312) "w")
+(modify-syntax-entry (make-char 'chinese-gb2312 33) "_")
+(modify-syntax-entry (make-char 'chinese-gb2312 34) "_")
+(modify-syntax-entry (make-char 'chinese-gb2312 41) "_")
+(modify-syntax-entry ?\\e$A!2\e(B "(\e$A!3\e(B")
+(modify-syntax-entry ?\\e$A!4\e(B "(\e$A!5\e(B")
+(modify-syntax-entry ?\\e$A!6\e(B "(\e$A!7\e(B")
+(modify-syntax-entry ?\\e$A!8\e(B "(\e$A!9\e(B")
+(modify-syntax-entry ?\\e$A!:\e(B "(\e$A!;\e(B")
+(modify-syntax-entry ?\\e$A!<\e(B "(\e$A!=\e(B")
+(modify-syntax-entry ?\\e$A!>\e(B "(\e$A!?\e(B")
+(modify-syntax-entry ?\\e$A!3\e(B ")\e$A!2\e(B")
+(modify-syntax-entry ?\\e$A!5\e(B ")\e$A!4\e(B")
+(modify-syntax-entry ?\\e$A!7\e(B ")\e$A!6\e(B")
+(modify-syntax-entry ?\\e$A!9\e(B ")\e$A!8\e(B")
+(modify-syntax-entry ?\\e$A!;\e(B ")\e$A!:\e(B")
+(modify-syntax-entry ?\\e$A!=\e(B ")\e$A!<\e(B")
+(modify-syntax-entry ?\\e$A!?\e(B ")\e$A!>\e(B")
+
+(modify-category-entry (make-char 'chinese-gb2312) ?c)
+(modify-category-entry (make-char 'chinese-gb2312) ?\|)
+(modify-category-entry (make-char 'chinese-gb2312 35) ?A)
+(modify-category-entry (make-char 'chinese-gb2312 36) ?H)
+(modify-category-entry (make-char 'chinese-gb2312 37) ?K)
+(modify-category-entry (make-char 'chinese-gb2312 38) ?G)
+(modify-category-entry (make-char 'chinese-gb2312 39) ?Y)
+(modify-category-entry (make-char 'chinese-gb2312 35) ?A)
+(let ((row 48))
+ (while (< row 127)
+ (modify-category-entry (make-char 'chinese-gb2312 row) ?C)
+ (setq row (1+ row))))
+
+;; Chinese character set (BIG5)
+
+(let ((generic-big5-1-char (make-char 'chinese-big5-1))
+ (generic-big5-2-char (make-char 'chinese-big5-2)))
+ (modify-syntax-entry generic-big5-1-char "w")
+ (modify-syntax-entry generic-big5-2-char "w")
+
+ (modify-category-entry generic-big5-1-char ?c)
+ (modify-category-entry generic-big5-2-char ?c)
+
+ (modify-category-entry generic-big5-1-char ?C)
+ (modify-category-entry generic-big5-2-char ?C)
+
+ (modify-category-entry generic-big5-1-char ?\|)
+ (modify-category-entry generic-big5-2-char ?\|))
+
+
+;; Chinese character set (CNS11643)
+
+(let ((cns-list '(chinese-cns11643-1
+ chinese-cns11643-2
+ chinese-cns11643-3
+ chinese-cns11643-4
+ chinese-cns11643-5
+ chinese-cns11643-6
+ chinese-cns11643-7))
+ generic-char)
+ (while cns-list
+ (setq generic-char (make-char (car cns-list)))
+ (modify-syntax-entry generic-char "w")
+ (modify-category-entry generic-char ?c)
+ (modify-category-entry generic-char ?C)
+ (modify-category-entry generic-char ?|)
+ (setq cns-list (cdr cns-list))))
+
+;; Cyrillic character set (ISO-8859-5)
+
+(modify-category-entry (make-char 'cyrillic-iso8859-5) ?y)
+
+(let ((c 160))
+ (while (< c 256)
+ (modify-syntax-entry (make-char 'cyrillic-iso8859-5 c) "w")
+ (setq c (1+ c))))
+(modify-syntax-entry ?\e,L-\e(B ".")
+(modify-syntax-entry ?\e,Lp\e(B ".")
+(modify-syntax-entry ?\e,L}\e(B ".")
+
+;; Ethiopic character set
+
+(modify-category-entry (make-char 'ethiopic) ?e)
+
+;; European character set (Latin-1,2,3,4,5)
+
+(modify-category-entry (make-char 'latin-iso8859-1) ?l)
+(modify-category-entry (make-char 'latin-iso8859-2) ?l)
+(modify-category-entry (make-char 'latin-iso8859-3) ?l)
+(modify-category-entry (make-char 'latin-iso8859-4) ?l)
+(modify-category-entry (make-char 'latin-iso8859-9) ?l)
+
+;; ISO-8859-1 (Latin-1)
+(let ((c 64))
+ (while (< c 128) ; from '\e,A@\e(B' to '\e,A\7f\e(B'
+ (modify-syntax-entry (make-char 'latin-iso8859-1 c) "w")
+ (setq c (1+ c)))
+ (modify-syntax-entry (make-char 'latin-iso8859-1 32) "w") ; NBSP
+ (modify-syntax-entry ?\e,AW\e(B "_")
+ (modify-syntax-entry ?\e,Aw\e(B "_")
+ )
+
+;; ISO-8859-2 (Latin-2)
+(let ((c 190))
+ (while (< c 255)
+ (modify-syntax-entry (make-char 'latin-iso8859-2 c) "w")
+ (setq c (1+ c))))
+(let ((chars '(?\e,B!\e(B ?\e,B#\e(B ?\e,B%\e(B ?\e,B&\e(B ?\e,B)\e(B ?\e,B*\e(B ?\e,B+\e(B ?\e,B,\e(B ?\e,B.\e(B ?\e,B/\e(B ?\e,B1\e(B ?\e,B3\e(B ?\e,B5\e(B ?\e,B6\e(B ?\e,B9\e(B ?\e,B:\e(B ?\e,B;\e(B ?\e,B<\e(B)))
+ (while chars
+ (modify-syntax-entry (car chars) "w")
+ (setq chars (cdr chars))))
+(modify-syntax-entry (make-char 'latin-iso8859-2 160) "w") ; NBSP
+(modify-syntax-entry ?\e,BW\e(B ".")
+(modify-syntax-entry ?\e,Bw\e(B ".")
+
+;; Greek character set (ISO-8859-7)
+
+(modify-category-entry (make-char 'greek-iso8859-7) ?g)
+
+(let ((c 182))
+ (while (< c 255)
+ (modify-syntax-entry (make-char 'greek-iso8859-7 c) "w")
+ (setq c (1+ c))))
+(modify-syntax-entry (make-char 'greek-iso8859-7 160) "w") ; NBSP
+(modify-syntax-entry ?\e,F7\e(B ".")
+(modify-syntax-entry ?\e,F;\e(B ".")
+(modify-syntax-entry ?\e,F=\e(B ".")
+
+;; Hebrew character set (ISO-8859-8)
+
+(modify-category-entry (make-char 'hebrew-iso8859-8) ?w)
+
+(let ((c 224))
+ (while (< c 251)
+ (modify-syntax-entry (make-char 'hebrew-iso8859-8 c) "w")
+ (setq c (1+ c))))
+(modify-syntax-entry (make-char 'hebrew-iso8859-8 160) "w") ; NBSP
+
+;; Indian character set (IS 13194 and other Emacs original Indian charsets)
+
+(modify-category-entry (make-char 'indian-is13194) ?i)
+(modify-category-entry (make-char 'indian-2-column) ?I)
+(modify-category-entry (make-char 'indian-1-column) ?I)
+
+;; Japanese character set (JISX0201-kana, JISX0201-roman, JISX0208, JISX0212)
+
+(modify-category-entry (make-char 'katakana-jisx0201) ?k)
+(modify-category-entry (make-char 'latin-jisx0201) ?r)
+(modify-category-entry (make-char 'japanese-jisx0208) ?j)
+(modify-category-entry (make-char 'japanese-jisx0212) ?j)
+(modify-category-entry (make-char 'japanese-jisx0208) ?\|)
+
+;; JISX0208
+(modify-syntax-entry (make-char 'japanese-jisx0208) "w")
+(modify-syntax-entry (make-char 'japanese-jisx0208 33) "_")
+(modify-syntax-entry (make-char 'japanese-jisx0208 34) "_")
+(modify-syntax-entry (make-char 'japanese-jisx0208 40) "_")
+(let ((chars '(?\e$B!<\e(B ?\e$B!+\e(B ?\e$B!,\e(B ?\e$B!3\e(B ?\e$B!4\e(B ?\e$B!5\e(B ?\e$B!6\e(B ?\e$B!7\e(B ?\e$B!8\e(B ?\e$B!9\e(B ?\e$B!:\e(B ?\e$B!;\e(B)))
+ (while chars
+ (modify-syntax-entry (car chars) "w")
+ (setq chars (cdr chars))))
+(modify-syntax-entry ?\\e$B!J\e(B "(\e$B!K\e(B")
+(modify-syntax-entry ?\\e$B!N\e(B "(\e$B!O\e(B")
+(modify-syntax-entry ?\\e$B!P\e(B "(\e$B!Q\e(B")
+(modify-syntax-entry ?\\e$B!V\e(B "(\e$B!W\e(B")
+(modify-syntax-entry ?\\e$B!X\e(B "(\e$B!Y\e(B")
+(modify-syntax-entry ?\\e$B!K\e(B ")\e$B!J\e(B")
+(modify-syntax-entry ?\\e$B!O\e(B ")\e$B!N\e(B")
+(modify-syntax-entry ?\\e$B!Q\e(B ")\e$B!P\e(B")
+(modify-syntax-entry ?\\e$B!W\e(B ")\e$B!V\e(B")
+(modify-syntax-entry ?\\e$B!Y\e(B ")\e$B!X\e(B")
+
+(modify-category-entry (make-char 'japanese-jisx0208 35) ?A)
+(modify-category-entry (make-char 'japanese-jisx0208 36) ?H)
+(modify-category-entry (make-char 'japanese-jisx0208 37) ?K)
+(modify-category-entry (make-char 'japanese-jisx0208 38) ?G)
+(modify-category-entry (make-char 'japanese-jisx0208 39) ?Y)
+(let ((row 48))
+ (while (< row 127)
+ (modify-category-entry (make-char 'japanese-jisx0208 row) ?C)
+ (setq row (1+ row))))
+(let ((chars '(?\e$B!<\e(B ?\e$B!+\e(B ?\e$B!,\e(B)))
+ (while chars
+ (modify-category-entry (car chars) ?K)
+ (modify-category-entry (car chars) ?H)
+ (setq chars (cdr chars))))
+(let ((chars '(?\e$B!3\e(B ?\e$B!4\e(B ?\e$B!5\e(B ?\e$B!6\e(B ?\e$B!7\e(B ?\e$B!8\e(B ?\e$B!9\e(B ?\e$B!:\e(B ?\e$B!;\e(B)))
+ (while chars
+ (modify-category-entry (car chars) ?C)
+ (setq chars (cdr chars))))
+
+;; JISX0212
+(modify-syntax-entry (make-char 'japanese-jisx0212) "w")
+(modify-syntax-entry (make-char 'japanese-jisx0212 33) "_")
+(modify-syntax-entry (make-char 'japanese-jisx0212 34) "_")
+(modify-syntax-entry (make-char 'japanese-jisx0212 35) "_")
+
+(modify-category-entry (make-char 'japanese-jisx0212 ) ?C)
+
+;; JISX0201-Kana
+(modify-syntax-entry (make-char 'katakana-jisx0201) "w")
+(let ((chars '(?\e(I!\e(B ?\e(I"\e(B ?\e(I#\e(B ?\e(I$\e(B ?\e(I%\e(B)))
+ (while chars
+ (modify-syntax-entry (car chars) ".")
+ (setq chars (cdr chars))))
+
+;; Korean character set (KSC5601)
+
+(modify-syntax-entry (make-char 'korean-ksc5601) "w")
+(modify-syntax-entry (make-char 'korean-ksc5601 33) "_")
+(modify-syntax-entry (make-char 'korean-ksc5601 34) "_")
+(modify-syntax-entry (make-char 'korean-ksc5601 38) "_")
+(modify-syntax-entry (make-char 'korean-ksc5601 39) "_")
+(modify-syntax-entry (make-char 'korean-ksc5601 40) "_")
+(modify-syntax-entry (make-char 'korean-ksc5601 41) "_")
+
+(modify-category-entry (make-char 'korean-ksc5601) ?h)
+(modify-category-entry (make-char 'korean-ksc5601 35) ?A)
+(modify-category-entry (make-char 'korean-ksc5601 37) ?G)
+(modify-category-entry (make-char 'korean-ksc5601 42) ?H)
+(modify-category-entry (make-char 'korean-ksc5601 43) ?K)
+(modify-category-entry (make-char 'korean-ksc5601 44) ?Y)
+
+;; Thai character set (TIS620)
+
+(modify-category-entry (make-char 'thai-tis620) ?t)
+
+(let ((deflist '(;; chars syntax category
+ ("\e,T!\e(B-\e,TCEG\e(B-\e,TN\e(B" "w" ?0) ; consonant
+ ("\e,TDFPRS`\e(B-\e,Te\e(B" "w" ?1) ; vowel base
+ ("\e,TQT\e(B-\e,TWgn\e(B" "w" ?2) ; vowel upper
+ ("\e,TX\e(B-\e,TZ\e(B" "w" ?3) ; vowel lower
+ ("\e,Th\e(B-\e,Tm\e(B" "w" ?4) ; tone mark
+ ("\e,TOfp\e(B-\e,Ty\e(B" "w" ?0) ; digit and misc
+ ("\e,T_oz{\e(B" "_" ?0) ; symbol
+ ))
+ elm chars len syntax category to ch i)
+ (while deflist
+ (setq elm (car deflist))
+ (setq chars (car elm)
+ len (length chars)
+ syntax (nth 1 elm)
+ category (nth 2 elm)
+ i 0)
+ (while (< i len)
+ (if (= (aref chars i) ?-)
+ (setq i (1+ i)
+ to (sref chars i))
+ (setq ch (sref chars i)
+ to ch))
+ (while (<= ch to)
+ (modify-syntax-entry ch syntax)
+ (modify-category-entry ch category)
+ (setq ch (1+ ch)))
+ (setq i (+ i (char-bytes to))))
+ (setq deflist (cdr deflist))))
+
+;; Vietnamese character set
+
+(let ((lower (make-char 'vietnamese-viscii-lower))
+ (upper (make-char 'vietnamese-viscii-upper)))
+ (modify-syntax-entry lower "w")
+ (modify-syntax-entry upper "w")
+ (modify-category-entry lower ?v)
+ (modify-category-entry upper ?v)
+ (modify-category-entry lower ?l) ; To make a word with
+ (modify-category-entry upper ?l) ; latin characters.
+ )
+
+\f
+;;; Setting word boundary.
+
+(setq word-combining-categories
+ '((?l . ?l)))
+
+(setq word-separating-categories ; (2-byte character sets)
+ '((?A . ?K) ; Alpha numeric - Katakana
+ (?A . ?C) ; Alpha numeric - Chinese
+ (?H . ?A) ; Hiragana - Alpha numeric
+ (?H . ?K) ; Hiragana - Katakana
+ (?H . ?C) ; Hiragana - Chinese
+ (?K . ?A) ; Katakana - Alpha numeric
+ (?K . ?C) ; Katakana - Chinese
+ (?C . ?A) ; Chinese - Alpha numeric
+ (?C . ?K) ; Chinese - Katakana
+ ))
--- /dev/null
+;; encoded-kb.el -- handler for inputting multibyte characters encoded somehow
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+(defvar encoded-kbd-mode nil
+ "Non-nil if in Encoded-kbd minor mode.")
+(put 'encoded-kbd-mode 'permanent-local t)
+
+(or (assq 'encoded-kbd-mode minor-mode-alist)
+ (setq minor-mode-alist
+ (cons '(encoded-kbd-mode " Encoded-kbd") minor-mode-alist)))
+
+(defvar encoded-kbd-mode-map
+ (let ((map (make-sparse-keymap))
+ (i 128))
+ (define-key map "\e" 'encoded-kbd-handle-iso2022-esc)
+ (while (< i 256)
+ (define-key map (vector i) 'encoded-kbd-handle-8bit)
+ (setq i (1+ i)))
+ map)
+ "Keymap for Encoded-kbd minor mode.")
+
+(or (assq 'encoded-kbd-mode minor-mode-map-alist)
+ (setq minor-mode-map-alist
+ (cons (cons 'encoded-kbd-mode encoded-kbd-mode-map)
+ minor-mode-map-alist)))
+
+;; Subsidiary keymaps for handling ISO2022 escape sequences.
+
+(defvar encoded-kbd-iso2022-esc-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "$" 'encoded-kbd-iso2022-esc-dollar-prefix)
+ (define-key map "(" 'encoded-kbd-iso2022-designation-prefix)
+ (define-key map ")" 'encoded-kbd-iso2022-designation-prefix)
+ (define-key map "," 'encoded-kbd-iso2022-designation-prefix)
+ (define-key map "-" 'encoded-kbd-iso2022-designation-prefix)
+ (append map '((t . encoded-kbd-outernal-command)))
+ map)
+ "Keymap for handling ESC code in Encoded-kbd mode.")
+
+(defvar encoded-kbd-iso2022-esc-dollar-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "(" 'encoded-kbd-iso2022-designation-prefix)
+ (define-key map ")" 'encoded-kbd-iso2022-designation-prefix)
+ (define-key map "," 'encoded-kbd-iso2022-designation-prefix)
+ (define-key map "-" 'encoded-kbd-iso2022-designation-prefix)
+ (define-key map "@" 'encoded-kbd-iso2022-designation)
+ (define-key map "A" 'encoded-kbd-iso2022-designation)
+ (define-key map "B" 'encoded-kbd-iso2022-designation)
+ (append map '((t . encoded-kbd-outernal-command)))
+ map)
+ "Keymap for handling ESC $ sequence handling in Encoded-kbd mode.")
+(fset 'encoded-kbd-iso2022-esc-dollar-prefix
+ encoded-kbd-iso2022-esc-dollar-map)
+
+(defvar encoded-kbd-iso2022-designation-map
+ (let ((map (make-sparse-keymap))
+ (i 48))
+ (while (< i 128)
+ (define-key map (char-to-string i) 'encoded-kbd-iso2022-designation)
+ (setq i (1+ i)))
+ (append map '((t . encoded-kbd-outernal-command)))
+ map)
+ "Keymap for handling ISO2022 designation sequence in Encoded-kbd mode.")
+(fset 'encoded-kbd-iso2022-designation-prefix
+ encoded-kbd-iso2022-designation-map)
+
+(defvar encoded-kbd-iso2022-non-ascii-map
+ (let ((map (make-keymap))
+ (i 32))
+ (while (< i 128)
+ (define-key map (char-to-string i) 'encoded-kbd-self-insert-iso2022-7bit)
+ (setq i (1+ i)))
+ map)
+ "Keymap for handling non-ASCII character set in Encoded-kbd mode.")
+
+;; One of the symbols `sjis', `iso2022-7', `iso2022-8', or `big5' to
+;; denote what kind of coding-system we are now handling in
+;; Encoded-kbd mode.
+(defvar encoded-kbd-coding nil)
+
+;; Keep information of designation state of ISO2022 encoding. This is
+;; a vector of character sets currently designated to each graphic
+;; registers (0..3).
+
+(defvar encoded-kbd-iso2022-designations nil)
+(make-variable-buffer-local 'encoded-kbd-iso2022-designations)
+(put 'encoded-kbd-iso2022-designations 'permanent-local t)
+
+;; Keep information of invocation state of ISO2022 encoding. This is
+;; a vector of graphic register numbers currently invoked to each
+;; graphic plane (0..1), the third element is a single shifted graphic
+;; register number.
+
+(defvar encoded-kbd-iso2022-invocations nil)
+(make-variable-buffer-local 'encoded-kbd-iso2022-invocations)
+(put 'encoded-kbd-iso2022-invocations 'permanent-local t)
+
+(defun encoded-kbd-iso2022-designation ()
+ "Do ISO2022 designation according to the curren key in Encoded-kbd mode.
+The following key sequence may cause multilingual text insertion."
+ (interactive)
+ (let ((key-seq (this-command-keys))
+ intermediate-char final-char
+ reg dimension chars charset)
+ (if (= (length key-seq) 3)
+ ;; (ESC) $ <intermediate-char> <final-char>
+ (setq intermediate-char (aref key-seq 1)
+ dimension 2
+ chars (if (< intermediate-char ?,) 94 96)
+ final-char (aref key-seq 2)
+ reg (mod intermediate-char 4))
+ (if (= (aref key-seq 1) ?$)
+ ;; (ESC) $ <final-char>
+ (setq dimension 2
+ chars 94
+ final-char (aref key-seq 1)
+ reg 0)
+ ;; (ESC) <intermediate-char> <final-char>
+ (setq intermediate-char (aref key-seq 0)
+ dimension 1
+ chars (if (< intermediate-char ?,) 94 96)
+ final-char (aref key-seq 1)
+ reg (mod intermediate-char 4))))
+ (if (setq charset (iso-charset dimension chars final-char))
+ (aset encoded-kbd-iso2022-designations reg charset)
+ (error "Character set of DIMENSION %s, CHARS %s, FINAL-CHAR `%c' is not supported"
+ dimension chars final-char))
+
+ (if (eq (aref encoded-kbd-iso2022-designations
+ (aref encoded-kbd-iso2022-invocations 0))
+ 'ascii)
+ ;; Graphic plane 0 (0x20..0x7f) is for ASCII. We don't have
+ ;; to handle characters in this range specially.
+ (throw 'exit nil)
+ ;; Graphic plane 0 is for non-ASCII.
+ (setq overriding-local-map encoded-kbd-iso2022-non-ascii-map))))
+
+(defun encoded-kbd-handle-iso2022-esc ()
+ (interactive)
+ (let ((overriding-local-map encoded-kbd-iso2022-esc-map))
+ (recursive-edit)))
+
+(defun encoded-kbd-handle-8bit ()
+ "Handle an 8-bit character enterned in Encoded-kbd mode."
+ (interactive)
+ (cond ((eq encoded-kbd-coding 'iso2022-7)
+ (error "Can't handle the character code %d" last-command-char))
+
+ ((eq encoded-kbd-coding 'iso2022-8)
+ (cond ((= last-command-char ?\216)
+ (aset encoded-kbd-iso2022-invocations 2 2))
+
+ ((= last-command-char ?\217)
+ (aset encoded-kbd-iso2022-invocations 2 3))
+
+ ((> last-command-char ?\240)
+ (encoded-kbd-self-insert-iso2022-8bit))
+
+ (t
+ (error "Can't handle the character code %d"
+ last-command-char))))
+
+ ((eq encoded-kbd-coding 'sjis)
+ (encoded-kbd-self-insert-sjis))
+
+ (t
+ (encoded-kbd-self-insert-big5))))
+
+(defun encoded-kbd-self-insert-iso2022-7bit ()
+ (interactive)
+ (let* ((charset (aref encoded-kbd-iso2022-designations
+ (or (aref encoded-kbd-iso2022-invocations 2)
+ (aref encoded-kbd-iso2022-invocations 0))))
+ (last-command-char
+ (if (= (charset-bytes charset) 1)
+ (make-char charset last-command-char)
+ (make-char charset last-command-char (read-char-exclusive)))))
+ (self-insert-command 1)
+ (aset encoded-kbd-iso2022-invocations 2 nil)
+ ))
+
+(defun encoded-kbd-self-insert-iso2022-8bit ()
+ (interactive)
+ (let* ((charset (aref encoded-kbd-iso2022-designations
+ (or (aref encoded-kbd-iso2022-invocations 2)
+ (aref encoded-kbd-iso2022-invocations 1))))
+ (last-command-char
+ (if (= (charset-bytes charset) 1)
+ (make-char charset last-command-char)
+ (make-char charset last-command-char (read-char-exclusive)))))
+ (self-insert-command 1)
+ (aset encoded-kbd-iso2022-invocations 2 nil)
+ ))
+
+(defun encoded-kbd-self-insert-sjis ()
+ (interactive)
+ (let ((last-command-char
+ (if (or (< last-command-char ?\xA0) (>= last-command-char ?\xE0))
+ (decode-sjis-char (+ (ash last-command-char 8)
+ (read-char-exclusive)))
+ (make-char 'latin-jisx0201 last-command-char))))
+ (self-insert-command 1)))
+
+(defun encoded-kbd-self-insert-big5 ()
+ (interactive)
+ (let ((last-command-char
+ (decode-big5-char (+ (ash last-command-char 8)
+ (read-char-exclusive)))))
+ (self-insert-command 1)))
+
+(defun encoded-kbd-mode (&optional arg)
+ "Toggle Encoded-kbd minor mode.
+With arg, turn Keyboard-kbd mode on in and only if arg is positive.
+
+When in Encoded-kbd mode, a text sent from a terminal keyboard
+is accepted as a multilingual text encoded in a coding-system
+set by the command `set-keyboard-coding-system'"
+ (interactive "P")
+ (setq encoded-kbd-mode
+ (if (null arg) (null encoded-kbd-mode)
+ (> (prefix-numeric-value arg) 0)))
+ (if encoded-kbd-mode
+ (let* ((coding (coding-system-vector (keyboard-coding-system)))
+ (input-mode (current-input-mode)))
+ (cond ((null coding)
+ (setq encoded-kbd-mode nil)
+ (error "No coding-system for terminal keyboard is set"))
+
+ ((= (coding-vector-type coding) 1) ; SJIS
+ (set-input-mode (nth 0 input-mode) (nth 1 input-mode)
+ 'use-8th-bit (nth 3 input-mode))
+ (setq encoded-kbd-coding 'sjis))
+
+ ((= (coding-vector-type coding) 2) ; ISO2022
+ (if (aref (coding-vector-flags coding) 7) ; 7-bit only
+ (setq encoded-kbd-coding 'iso2022-7)
+ (set-input-mode (nth 0 input-mode) (nth 1 input-mode)
+ 'use-8th-bit (nth 3 input-mode))
+ (setq encoded-kbd-coding 'iso2022-8))
+ (make-variable-buffer-local 'encoded-kbd-iso2022-designations)
+ (setq encoded-kbd-iso2022-designations (make-vector 4 nil))
+ (let ((flags (coding-vector-flags coding))
+ (i 0))
+ (while (< i 4)
+ (if (and (aref flags i)
+ (> (aref flags i) 0))
+ (aset encoded-kbd-iso2022-designations i
+ (aref flags i)))
+ (setq i (1+ i))))
+ (make-variable-buffer-local 'encoded-kbd-iso2022-invocations)
+ (setq encoded-kbd-iso2022-invocations (make-vector 3 0))
+ (aset encoded-kbd-iso2022-invocations 1 1))
+
+ ((= (coding-vector-type coding) 3) ; BIG5
+ (set-input-mode (nth 0 input-mode) (nth 1 input-mode)
+ 'use-8th-bit (nth 3 input-mode))
+ (setq encoded-kbd-coding 'big5))
+
+ (t
+ (setq encoded-kbd-mode nil)
+ (error "Coding-system `%s' is not supported in Encoded-kbd mode"
+ (keyboard-coding-system))))
+
+ (run-hooks 'encoded-kbd-mode-hook)))
+ (force-mode-line-update))
+
+;;; encoded-kb.el ends here
--- /dev/null
+;;; fontset.el --- Commands for handling fontset.
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: mule, multilingual, fontset
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Code:
+
+;; Set default REGISTRY property of charset to find an appropriate
+;; font for each charset. This is used to generate a font name in a
+;; fontset. If the value contains a character `-', the string before
+;; that is embeded in `CHARSET_REGISTRY' field, and the string after
+;; that is embeded in `CHARSET_ENCODING' field. If the value does not
+;; contain `-', the whole string is embeded in `CHARSET_REGISTRY'
+;; field, and a wild card character `*' is embeded in
+;; `CHARSET_ENCODING' field.
+
+(defvar x-charset-registries
+ '((ascii . "ISO8859-1")
+ (latin-iso8859-1 . "ISO8859-1")
+ (latin-iso8859-2 . "ISO8859-2")
+ (latin-iso8859-3 . "ISO8859-3")
+ (latin-iso8859-4 . "ISO8859-4")
+ (thai-tis620 . "TIS620")
+ (greek-iso8859-7 . "ISO8859-7")
+ (arabic-iso8859-6 . "ISO8859-6")
+ (hebrew-iso8859-8 . "ISO8859-8")
+ (katakana-jisx0201 . "JISX0201")
+ (latin-jisx0201 . "JISX0201")
+ (cyrillic-iso8859-5 . "ISO8859-5")
+ (latin-iso8859-9 . "ISO8859-9")
+ (japanese-jisx0208-1978 . "JISX0208.1978")
+ (chinese-gb2312 . "GB2312")
+ (japanese-jisx0208 . "JISX0208.1983")
+ (korean-ksc5601 . "KSC5601")
+ (japanese-jisx0212 . "JISX0212")
+ (chinese-cns11643-1 . "CNS11643.1992-1")
+ (chinese-cns11643-2 . "CNS11643.1992-2")
+ (chinese-cns11643-3 . "CNS11643.1992-3")
+ (chinese-cns11643-4 . "CNS11643.1992-4")
+ (chinese-cns11643-5 . "CNS11643.1992-5")
+ (chinese-cns11643-6 . "CNS11643.1992-6")
+ (chinese-cns11643-7 . "CNS11643.1992-7")
+ (chinese-big5-1 . "Big5")
+ (chinese-big5-2 . "Big5")
+ (chinese-sisheng . "sisheng_cwnn")
+ (vietnamese-viscii-lower . "VISCII1.1")
+ (vietnamese-viscii-upper . "VISCII1.1")
+ (arabic-digit . "MuleArabic-0")
+ (arabic-1-column . "MuleArabic-1")
+ (arabic-2-column . "MuleArabic-2")
+ (ipa . "MuleIPA")
+ (ethiopic . "Ethio")
+ (ascii-right-to-left . "ISO8859-1")
+ (indian-is13194 . "IS13194-Devanagari")
+ (indian-2-column . "MuleIndian-2")
+ (indian-1-column . "MuleIndian-1")
+ (lao . "lao.mule-1")))
+
+(let ((l x-charset-registries))
+ (while l
+ (put-charset-property (car (car l)) 'x-charset-registry (cdr (car l)))
+ (setq l (cdr l))))
+
+;; Set arguments in `font-encoding-alist' (which see).
+(defun set-font-encoding (pattern charset encoding)
+ (let ((slot (assoc pattern font-encoding-alist)))
+ (if slot
+ (let ((place (assq charset (cdr slot))))
+ (if place
+ (setcdr place encoding)
+ (setcdr slot (cons (cons charset encoding) (cdr slot)))))
+ (setq font-encoding-alist
+ (cons (list pattern (cons charset encoding)) font-encoding-alist)))
+ ))
+
+(set-font-encoding "ISO8859-1" 'ascii 0)
+(set-font-encoding "JISX0201" 'latin-jisx0201 0)
+
+;; Setting for suppressing XLoadQueryFont on big fonts.
+(setq x-pixel-size-width-font-regexp
+ "gb2312\\|jisx0208\\|ksc5601\\|cns11643\\|big5")
+
+;;; XLFD (X Logical Font Description) format handler.
+
+;; Define XLFD's field index numbers. ; field name
+(defconst xlfd-regexp-foundry-subnum 0) ; FOUNDRY
+(defconst xlfd-regexp-family-subnum 1) ; FAMILY_NAME
+(defconst xlfd-regexp-weight-subnum 2) ; WEIGHT_NAME
+(defconst xlfd-regexp-slant-subnum 3) ; SLANT
+(defconst xlfd-regexp-swidth-subnum 4) ; SETWIDTH_NAME
+(defconst xlfd-regexp-adstyle-subnum 5) ; ADD_STYLE_NAME
+(defconst xlfd-regexp-pixelsize-subnum 6) ; PIXEL_SIZE
+(defconst xlfd-regexp-pointsize-subnum 7) ; POINT_SIZE
+(defconst xlfd-regexp-resx-subnum 8) ; RESOLUTION_X
+(defconst xlfd-regexp-resy-subnum 9) ; RESOLUTION_Y
+(defconst xlfd-regexp-spacing-subnum 10) ; SPACING
+(defconst xlfd-regexp-avgwidth-subnum 11) ; AVERAGE_WIDTH
+(defconst xlfd-regexp-registry-subnum 12) ; CHARSET_REGISTRY
+(defconst xlfd-regexp-encoding-subnum 13) ; CHARSET_ENCODING
+
+;; Regular expression matching against a fontname which conforms to
+;; XLFD (X Logical Font Description). All fields in XLFD should be
+;; not be omitted (but can be a wild card) to be matched.
+(defconst xlfd-tight-regexp
+ "^\
+-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\
+-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\
+-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)$")
+
+;; List of field numbers of XLFD whose values are numeric.
+(defconst xlfd-regexp-numeric-subnums
+ (list xlfd-regexp-pixelsize-subnum ;6
+ xlfd-regexp-pointsize-subnum ;7
+ xlfd-regexp-resx-subnum ;8
+ xlfd-regexp-resy-subnum ;9
+ xlfd-regexp-avgwidth-subnum ;11
+ ))
+
+(defun x-decompose-font-name (pattern)
+ "Decompose PATTERN into XLFD's fields and return vector of the fields.
+The length of the vector is 14.
+
+If PATTERN doesn't conform to XLFD, try to get a full XLFD name from
+X server and use the information of the full name to decompose
+PATTERN. If no full XLFD name is gotten, return nil."
+ (let (xlfd-fields fontname)
+ (if (string-match xlfd-tight-regexp pattern)
+ (let ((i 0))
+ (setq xlfd-fields (make-vector 14 nil))
+ (while (< i 14)
+ (aset xlfd-fields i (match-string (1+ i) pattern))
+ (setq i (1+ i)))
+ xlfd-fields)
+ (setq fontname (condition-case nil
+ (x-resolve-font-name pattern)
+ (error)))
+ (if (and fontname
+ (string-match xlfd-tight-regexp fontname))
+ (let ((len (length pattern))
+ (i 0)
+ l)
+ (setq xlfd-fields (make-vector 14 nil))
+ (while (< i 14)
+ (aset xlfd-fields i
+ (cons (match-beginning (1+ i))
+ (match-string (1+ i) fontname)))
+ (setq i (1+ i)))
+ (setq i 0)
+ (while (< i len)
+ (let ((ch (aref pattern i)))
+ (if (= ch ??)
+ (setq pattern (concat (substring pattern 0 i)
+ "\\(.\\)"
+ (substring pattern (1+ i)))
+ len (+ len 4)
+ i (+ i 4))
+ (if (= ch ?*)
+ (setq pattern (concat (substring pattern 0 i)
+ "\\(.*\\)"
+ (substring pattern (1+ i)))
+ len (+ len 5)
+ i (+ i 5))
+ (setq i (1+ i))))))
+ (string-match pattern fontname)
+ (setq l (cdr (cdr (match-data))))
+ (setq i 0)
+ (while (< i 14)
+ (if (or (null l) (< (car (aref xlfd-fields i)) (car l)))
+ (progn
+ (aset xlfd-fields i (cdr (aref xlfd-fields i)))
+ (setq i (1+ i)))
+ (if (< (car (aref xlfd-fields i)) (car (cdr l)))
+ (progn
+ (aset xlfd-fields i nil)
+ (setq i (1+ i)))
+ (setq l (cdr (cdr l))))))
+ xlfd-fields)))))
+
+(defsubst x-compose-font-name (xlfd-fields)
+ "Compose X's fontname from FIELDS.
+FIELDS is a vector of XLFD fields.
+If a field is nil, wild-card character `*' is embedded."
+ (concat "-" (mapconcat (lambda (x) (or x "*")) xlfd-fields "-")))
+
+(defun x-complement-fontset-spec (xlfd-fields fontlist)
+ "Complement FONTLIST for all charsets based on XLFD-FIELDS and return it.
+XLFD-FIELDS is a vector of XLFD (X Logical Font Description) fields.
+FONTLIST is an alist of cons of charset and fontname.
+
+Fontnames for charsets not listed in FONTLIST are generated from
+XLFD-FIELDS and a property of x-charset-register of each charset
+automatically."
+ (let ((charsets charset-list))
+ (while charsets
+ (let ((charset (car charsets)))
+ (if (null (assq charset fontlist))
+ (let ((registry (get-charset-property charset
+ 'x-charset-registry)))
+ (if (string-match "-" registry)
+ ;; REGISTRY contains `CHARSET_ENCODING' field.
+ (progn
+ (aset xlfd-fields xlfd-regexp-registry-subnum
+ (substring registry 0 (match-beginning 0)))
+ (aset xlfd-fields xlfd-regexp-encoding-subnum
+ (substring registry (match-end 0))))
+ (aset xlfd-fields xlfd-regexp-registry-subnum
+ (concat registry "*"))
+ (aset xlfd-fields xlfd-regexp-encoding-subnum "*"))
+ (setq fontlist
+ (cons (cons charset (x-compose-font-name xlfd-fields))
+ fontlist)))))
+ (setq charsets (cdr charsets))))
+ fontlist)
+
+;; Return a list to be appended to `x-fixed-font-alist' when
+;; `mouse-set-font' is called.
+(defun generate-fontset-menu ()
+ (let ((fontsets global-fontset-alist)
+ fontset-name
+ l)
+ (while fontsets
+ (setq fontset-name (car (car fontsets)) fontsets (cdr fontsets))
+ (if (string-match "fontset-\\([^-]+\\)" fontset-name)
+ ;; This fontset has a nickname. Just show it.
+ (let ((nickname (match-string 1 fontset-name)))
+ (setq l (cons (list (concat ".." nickname) fontset-name) l)))
+ (setq l (cons (list fontset-name fontset-name) l))))
+ (cons "Fontset" l)))
+
+(defun fontset-plain-name (fontset)
+ "Return a plain and descriptive name of FONTSET."
+ (let ((xlfd-fields (x-decompose-font-name fontset)))
+ (if xlfd-fields
+ (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum))
+ (slant (aref xlfd-fields xlfd-regexp-slant-subnum))
+ (swidth (aref xlfd-fields xlfd-regexp-swidth-subnum))
+ (size (aref xlfd-fields xlfd-regexp-pixelsize-subnum))
+ name)
+ (if (integerp size)
+ (setq name (format "%d " size))
+ (setq name ""))
+ (if (string-match "bold\\|demibold" weight)
+ (setq name (concat name weight " ")))
+ (cond ((string= slant "i")
+ (setq name (concat name "italic ")))
+ ((string= slant "o")
+ (setq name (concat name "slant ")))
+ ((string= slant "ri")
+ (setq name (concat name "reverse italic ")))
+ ((string= slant "ro")
+ (setq name (concat name "reverse slant "))))
+ (if (= (length name) 0)
+ ;; No descriptive fields found.
+ fontset
+ name))
+ fontset)))
+
+(defun create-fontset-from-fontset-spec (fontset-spec)
+ "Create a fontset from fontset specification string FONTSET-SPEC.
+FONTSET-SPEC is a string of the format:
+ FONTSET-NAME,CHARSET-NAME0:FONT-NAME0,CHARSET-NAME1:FONT-NAME1, ...
+Any number of SPACE, TAB, and NEWLINE can be put before and after commas."
+ (if (string-match "[^,]+" fontset-spec)
+ (let* ((idx2 (match-end 0))
+ (name (match-string 0 fontset-spec))
+ fontlist charset xlfd-fields)
+ (while (string-match "[, \t\n]*\\([^:]+\\):\\([^,]+\\)"
+ fontset-spec idx2)
+ (setq idx2 (match-end 0))
+ (setq charset (intern (match-string 1 fontset-spec)))
+ (if (charsetp charset)
+ (setq fontlist (cons (cons charset (match-string 2 fontset-spec))
+ fontlist))))
+ (if (setq xlfd-fields (x-decompose-font-name name))
+ ;; If NAME conforms to XLFD, complement FONTLIST for
+ ;; charsets not specified in FONTSET-SPEC.
+ (setq fontlist
+ (x-complement-fontset-spec xlfd-fields fontlist)))
+ (new-fontset name fontlist))))
+
+\f
+;; Create default fontset from 16 dots fonts which are the most widely
+;; installed fonts.
+(defvar default-fontset-spec
+ "-*-fixed-medium-r-normal-*-16-*-*-*-*-*-fontset-default,
+ chinese-gb2312:-*-medium-r-normal-*-16-*-gb2312*-*,
+ korean-ksc5601:-*-medium-r-normal-*-16-*-ksc5601*-*,
+ chinese-cns11643-1:-*-medium-r-normal-*-16-*-cns11643*-1,
+ chinese-cns11643-2:-*-medium-r-normal-*-16-*-cns11643*-2,
+ chinese-cns11643-3:-*-medium-r-normal-*-16-*-cns11643*-3,
+ chinese-cns11643-4:-*-medium-r-normal-*-16-*-cns11643*-4,
+ chinese-cns11643-5:-*-medium-r-normal-*-16-*-cns11643*-5,
+ chinese-cns11643-6:-*-medium-r-normal-*-16-*-cns11643*-6,
+ chinese-cns11643-7:-*-medium-r-normal-*-16-*-cns11643*-7"
+ "String of fontset spec of a default fontset.
+See the documentation of `create-fontset-from-fontset-spec' for the format.")
+
+;; Create fontsets from X resources of the name `fontset-N (class
+;; Fontset-N)' where N is integer 0, 1, ...
+;; The values of the resources the string of the same format as
+;; `default-fontset-spec'.
+
+(defun create-fontset-from-x-resource ()
+ (let ((idx 0)
+ fontset-spec)
+ (while (setq fontset-spec (x-get-resource (concat "fontset-" idx)
+ (concat "Fontset-" idx)))
+ (create-fontset-from-fontset-spec fontset-spec)
+ (setq idx (1+ idx)))))
+
+(defsubst fontset-list ()
+ "Returns a list of all defined fontset names."
+ (mapcar 'car global-fontset-alist))
+
+;;
+(provide 'fontset)
+
+;;; fontset.el ends here
--- /dev/null
+;;; isearch-x.el --- extended isearch handling commands
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: multilingual, isearch
+
+;; Author: Kenichi HANDA <handa@etl.go.jp>
+;; Maintainer: Kenichi HANDA <handa@etl.go.jp>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Code:
+
+;;;###autoload
+(defun isearch-toggle-specified-input-method ()
+ "Select and toggle specified input method in interactive search."
+ (interactive)
+ ;; Let the command `toggle-input-method' ask users to select input
+ ;; method interactively.
+ (setq default-input-method nil)
+ (isearch-toggle-input-method))
+
+;;;###autoload
+(defun isearch-toggle-input-method ()
+ "Toggle input method in interactive search."
+ (interactive)
+ (if isearch-multibyte-characters-flag
+ (setq isearch-multibyte-characters-flag nil)
+ (condition-case nil
+ (progn
+ (if (null default-input-method)
+ (let ((overriding-terminal-local-map nil))
+ ;; No input method has ever been selected. Select one
+ ;; interactively now. This also sets
+ ;; `default-input-method-title' to the title of the
+ ;; selected input method.
+ (toggle-input-method)
+ ;; And, inactivate it for the moment.
+ (toggle-input-method)))
+ (setq isearch-multibyte-characters-flag t))
+ (error (ding))))
+ (isearch-update))
+
+(defun isearch-input-method-after-insert-chunk-function ()
+ (funcall inactivate-current-input-method-function))
+
+(defun isearch-process-search-multibyte-characters (last-char)
+ (let* ((overriding-terminal-local-map nil)
+ ;; Let input method exit when a chunk is inserted.
+ (input-method-after-insert-chunk-hook
+ '(isearch-input-method-after-insert-chunk-function))
+ (input-method-inactivate-hook '(exit-minibuffer))
+ ;; Let input method work rather tersely.
+ (input-method-tersely-flag t)
+ str)
+ (setq unread-command-events (cons last-char unread-command-events))
+ (setq str (read-multilingual-string (concat (isearch-message-prefix)
+ isearch-message)))
+ (isearch-process-search-string str str)))
+
+;;; isearch-x.el ends here
--- /dev/null
+;;; kinsoku.el --- `Kinsoku' processing functions.
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: kinsoku
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; `Kinsoku' processing is to prohibit specific characters to be
+;; placed at beginning of line or at end of line. Characters not to
+;; be placed at beginning and end of line have character category `>'
+;; and `<' respectively. This restriction is dissolved by making a
+;; line longer or shorter.
+;;
+;; `Kinsoku' is a Japanese word which originally means ordering to
+;; stay in one place, and is used for the text processing described
+;; above in the context of text formatting.
+
+;;; Code:
+
+(defvar kinsoku-limit 4
+ "How many more columns we can make lines longer by `kinsoku' processing.
+The value 0 means there's no limitation.")
+
+;; Setting character category `>' for characters which should not be
+;; placed at beginning of line.
+(let* ((kinsoku-bol
+ (concat
+ ;; ASCII
+ "!)-_~}]:;',.?"
+ ;; Japanese JISX0208
+ "\e$B!"!#!$!%!&!'!(!)!*!+!,!-!.!/!0!1!2!3!4!5!6!7!8!9!:!;!<!=!>\e(B\
+\e$B!?!@!A!B!C!D!E!G!I!K!M!O!Q!S!U!W!Y![!k!l!m!n\e(B\
+\e$B$!$#$%$'$)$C$c$e$g$n%!%#%%%'%)%C%c%e%g%n%u%v\e(B"
+ ;; Chinese GB2312
+ "\e$A!"!##.#,!$!%!&!'!(!)!*!+!,!-!/!1#)!3!5!7!9!;!=\e(B\
+\e$A!?#;#:#?#!!@!A!B!C!c!d!e!f#/#\#"#_#~#|(e\e(B"
+ ;; Chinese BIG5
+ "\e$(0!"!#!$!%!&!'!(!)!*!+!,!-!.!/!0!1!2\e(B\
+\e$(0!3!4!5!6!7!8!9!:!;!<!=!?!A!C!E!G!I!K\e(B\
+\e$(0!M!O!Q\e(B \e$(0!S!U!W!Y![!]!_!a!c!e!g!i!k!q\e(B\
+\e$(0"#"$"%"&"'"(")"*"+","2"3"4"j"k"l"x%7\e(B"))
+ (len (length kinsoku-bol))
+ (idx 0)
+ ch)
+ (while (< idx len)
+ (setq ch (sref kinsoku-bol idx)
+ idx (+ idx (char-bytes ch)))
+ (modify-category-entry ch ?>)))
+
+;; Setting character category `<' for characters which should not be
+;; placed at end of line.
+(let* ((kinsoku-eol
+ (concat
+ ;; ASCII
+ "({[`"
+ ;; Japanese JISX0208
+ "\e$B!F!H!J!L!N!P!R!T!V!X!Z!k!l!m!n!w!x\e(B\
+\e$A!.!0#"#(!2!4!6!8!:!<!>!c!d!e#@!f!l\e(B"
+ ;; Chinese GB2312
+ "\e$A(E(F(G(H(I(J(K(L(M(N(O(P(Q(R(S(T(U(V(W(X(Y(h\e(B\
+\e$(0!>!@!B!D!F!H!J!L!N!P!R!T!V!X!Z!\!^!`!b\e(B"
+ ;; Chinese BIG5
+ "\e$(0!d!f!h!j!k!q!p"i"j"k"n"x$u$v$w$x$y$z${\e(B\
+\e$(0$|$}$~%!%"%#%$%%%&%'%(%)%*%+%:\e(B"))
+ (len (length kinsoku-eol))
+ (idx 0)
+ ch)
+ (while (< idx len)
+ (setq ch (sref kinsoku-eol idx)
+ idx (+ idx (char-bytes ch)))
+ (modify-category-entry ch ?<)))
+
+;; Try to resolve `kinsoku' restriction by making the current line longer.
+(defun kinsoku-longer ()
+ (let ((pos-and-column (save-excursion
+ (forward-char 1)
+ (while (aref (char-category-set (following-char)) ?>)
+ (forward-char 1))
+ (cons (point) (current-column)))))
+ (if (or (<= kinsoku-limit 0)
+ (< (cdr pos-and-column) (+ (current-fill-column) kinsoku-limit)))
+ (goto-char (car pos-and-column)))))
+
+;; Try to resolve `kinsoku' restriction by making the current line shorter.
+;; The line can't be broken before the buffer position LINEBEG."
+(defun kinsoku-shorter (linebeg)
+ (let ((pos (save-excursion
+ (forward-char -1)
+ (while (and (< linebeg (point))
+ (or (aref (char-category-set (preceding-char)) ?<)
+ (aref (char-category-set (following-char)) ?>)))
+ (forward-char -1))
+ (point))))
+ (if (< linebeg pos)
+ (goto-char pos))))
+
+;;;###autoload
+(defun kinsoku (linebeg)
+ "Go to a line breaking position near point by doing `kinsoku' processing.
+LINEBEG is a buffer position we can't break a line before.
+
+`Kinsoku' processing is to prohibit specific characters to be placed
+at beginning of line or at end of line. Characters not to be placed
+at beginning and end of line have character category `>' and `<'
+respectively. This restriction is dissolved by making a line longer or
+shorter.
+
+`Kinsoku' is a Japanese word which originally means ordering to stay
+in one place, and is used for the text processing described above in
+the context of text formatting."
+ (if (or (and
+ ;; The character after point can't be placed at beginning
+ ;; of line.
+ (aref (char-category-set (following-char)) ?>)
+ ;; We at first try to dissolve this situation by making a
+ ;; line longer. If it fails, then try making a line
+ ;; shorter.
+ (not (kinsoku-longer)))
+ ;; The character before point can't be placed at end of line.
+ (aref (char-category-set (preceding-char)) ?<))
+ (kinsoku-shorter linebeg)))
+
+;; kinsoku.el ends here
--- /dev/null
+;; kkc.el -- Kana Kanji converter
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: mule, multilingual, Japanese, SKK
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; These routines provide a simple and easy-to-use converter from
+;; Kana-string to Kana-Kanji-mixed-string. This converter (here after
+;; KKC) uses a SKK dictionary to get information how to convert
+;; Kana-string. Since KKC can't be fully automated, we need an
+;; interaction with a user to decide the correct conversion. For
+;; that, we provide KKC major mode.
+
+;;; Code:
+
+(require 'skkdic-utl)
+
+(defvar kkc-input-method-title "\e$B4A\e(B"
+ "String denoting KKC input method.
+This string is shown at mode line when users are in KKC mode.")
+
+(defvar kkc-init-file-name "~/.kkcrc"
+ "Name of a file which contains user's initial setup code for KKC.")
+
+;; A flag to control a file specified by `kkc-init-file-name'.
+;; The value nil means the file is not yet consulted.
+;; The value t means the file has already been consulted but there's
+;; no need of updating it yet.
+;; Any other value means that we must update the file before exiting Emacs.
+(defvar kkc-init-file-flag nil)
+
+;; Cash data for `kkc-lookup-key'. This may be initialized by loading
+;; a file specified by `kkc-init-file-name'. If any elements are
+;; modified, the data is written out to the file when exiting Emacs.
+(defvar kkc-lookup-cache '(kkc-lookup-cache))
+
+(defun kkc-save-init-file ()
+ "Save initial setup code for KKC to a file specified by `kkc-init-file-name'"
+ (if (and kkc-init-file-flag
+ (not (eq kkc-init-file-flag t)))
+ (let ((coding-system-for-write 'coding-system-iso-2022-7))
+ (write-region (format "(setq kkc-lookup-cache '%S)\n" kkc-lookup-cache)
+ nil
+ kkc-init-file-name))))
+
+;; Sequence of characters to be used for indexes for shown list. The
+;; Nth character is for the Nth conversion in the list currently shown.
+(defvar kkc-show-conversion-list-index-chars
+ "1234567890abcdefghijklmnopqrsuvwxyz")
+
+(defvar kkc-mode-map
+ (let ((map (make-keymap))
+ (i 0))
+ (while (< i ? )
+ (define-key map (char-to-string i) 'undefined)
+ (setq i (1+ i)))
+ (while (< i 128)
+ (define-key map (char-to-string i) 'kkc-non-kkc-command)
+ (setq i (1+ i)))
+ (setq i 0)
+ (let ((len (length kkc-show-conversion-list-index-chars)))
+ (while (< i len)
+ (define-key map
+ (char-to-string (aref kkc-show-conversion-list-index-chars i))
+ 'kkc-select-from-list)
+ (setq i (1+ i))))
+ (define-key map " " 'kkc-next)
+ (define-key map (char-to-string help-char) 'help-command)
+ (define-key map "\r" 'kkc-terminate)
+ (define-key map "\C-@" 'kkc-first-char-only)
+ (define-key map "\C-n" 'kkc-next)
+ (define-key map "\C-p" 'kkc-prev)
+ (define-key map "\C-i" 'kkc-shorter)
+ (define-key map "\C-o" 'kkc-longer)
+ (define-key map "\C-c" 'kkc-cancel)
+ (define-key map "\C-?" 'kkc-cancel)
+ (define-key map "\C-f" 'kkc-next-phrase)
+ (define-key map "K" 'kkc-katakana)
+ (define-key map "H" 'kkc-hiragana)
+ (define-key map "l" 'kkc-show-conversion-list-or-next-group)
+ (define-key map "L" 'kkc-show-conversion-list-or-prev-group)
+ (define-key map [?\C-\ ] 'kkc-first-char-only)
+ (define-key map [delete] 'kkc-cancel)
+ (define-key map [return] 'kkc-terminate)
+ (append map '((t . kkc-non-kkc-command))))
+ "Keymap for KKC (Kana Kanji Conversion) mode.")
+
+(defun kkc-mode ()
+ "Major mode for converting Kana string to Kanji-Kana mixed string.
+Commands:
+\\{kkc-mode-map}"
+ (setq major-mode 'kkc-mode)
+ (setq mode-name "KKC")
+ (use-local-map kkc-mode-map)
+ (run-hooks 'kkc-mode-hook))
+
+;;; Internal variables used in KKC.
+
+;; The current Kana string to be converted.
+(defvar kkc-original-kana nil)
+
+;; The current key sequence (vector of Kana characters) generated from
+;; `kkc-original-kana'.
+(defvar kkc-current-key nil)
+
+;; List of the current conversions for `kkc-current-key'.
+(defvar kkc-current-conversions nil)
+
+;; Vector of the same length as `kkc-current-conversion'. The first
+;; element is a vector of:
+;; o index number of the first conversion shown previously,
+;; o index number of a conversion next of the last one shown previously,
+;; o the shown string itself.
+;; The remaining elements are widths (including columns for index
+;; numbers) of conversions stored in the same order as in
+;; `kkc-current-conversion'.
+(defvar kkc-current-conversions-width nil)
+
+(defvar kkc-show-conversion-list-count 4
+ "Count of successive `kkc-next' or `kkc-prev' to show conversion list.")
+
+;; Provided that `kkc-current-key' is [A B C D E F G H I], the current
+;; conversion target is [A B C D E F], the sequence of which
+;; conversion is found is [A B C D]:
+;;
+;; A B C D E F G H I
+;; kkc-overlay-head (black): |<--------->|
+;; kkc-overlay-tail (underline): |<------->|
+;; kkc-length-head: |<--------->|
+;; kkc-length-converted: |<----->|
+;;
+(defvar kkc-overlay-head nil)
+(defvar kkc-overlay-tail nil)
+(defvar kkc-length-head nil)
+(defvar kkc-length-converted nil)
+
+;; Cursor type (`box' or `bar') of the current frame.
+(defvar kkc-cursor-type nil)
+
+;; Flag to tell if the current conversion is canceled. If non-nil,
+;; the value is a buffer position of the head of currently active
+;; conversion region.
+(defvar kkc-canceled nil)
+
+;; Lookup SKK dictionary to set list of conversions in
+;; kkc-current-conversions for key sequence kkc-current-key of length
+;; LEN. If no conversion is found in the dictionary, don't change
+;; kkc-current-conversions and return nil.
+;; Postfixes are handled only if POSTFIX is non-nil.
+(defun kkc-lookup-key (len &optional postfix)
+ ;; At first, prepare cache data if any.
+ (if (not kkc-init-file-flag)
+ (progn
+ (setq kkc-init-file-flag t)
+ (add-hook 'kill-emacs-hook 'kkc-save-init-file)
+ (if (file-readable-p kkc-init-file-name)
+ (condition-case nil
+ (load-file "~/.kkcrc")
+ (error (message "Invalid data in %s" kkc-init-file-name)
+ (ding))))))
+ (let ((entry (lookup-nested-alist kkc-current-key kkc-lookup-cache len 0 t)))
+ (if (consp (car entry))
+ (setq kkc-length-converted len
+ kkc-current-conversions-width nil
+ kkc-current-conversions (car entry))
+ (setq entry (skkdic-lookup-key kkc-current-key len postfix))
+ (if entry
+ (progn
+ (setq kkc-length-converted len
+ kkc-current-conversions-width nil
+ kkc-current-conversions (cons 1 entry))
+ (if postfix
+ ;; Store this conversions in the cache.
+ (progn
+ (set-nested-alist kkc-current-key kkc-current-conversions
+ kkc-lookup-cache kkc-length-converted)
+ (setq kkc-init-file-flag 'kkc-lookup-cache)))
+ t)
+ (if (= len 1)
+ (setq kkc-length-converted 1
+ kkc-current-conversions-width nil
+ kkc-current-conversions (cons 0 nil)))))))
+
+;;;###autoload
+(defun kkc-region (from to)
+ "Convert Kana string in the current region to Kanji-Kana mixed string.
+After one candidate of conversion is shown in the region, users are
+put in KKC major mode to select a desirable conversion."
+ (interactive "r")
+ (setq kkc-original-kana (buffer-substring from to))
+ (goto-char from)
+
+ ;; Setup overlays.
+ (if (overlayp kkc-overlay-head)
+ (move-overlay kkc-overlay-head from to)
+ (setq kkc-overlay-head (make-overlay from to nil nil t))
+ (overlay-put kkc-overlay-head 'face 'highlight))
+ (if (overlayp kkc-overlay-tail)
+ (move-overlay kkc-overlay-tail to to)
+ (setq kkc-overlay-tail (make-overlay to to nil nil t))
+ (overlay-put kkc-overlay-tail 'face 'underline))
+
+ ;; After updating the conversion region with the first candidate of
+ ;; conversion, jump into a recursive editing environment with KKC
+ ;; mode .
+ (let ((overriding-local-map nil)
+ (previous-local-map (current-local-map))
+ (minor-mode-alist nil)
+ (minor-mode-map-alist nil)
+ (current-input-method-title kkc-input-method-title)
+ major-mode mode-name)
+ (unwind-protect
+ (progn
+ (setq kkc-canceled nil)
+ (setq kkc-current-key (string-to-vector kkc-original-kana))
+ (setq kkc-length-head (length kkc-current-key))
+ (setq kkc-length-converted 0)
+ (while (not (kkc-lookup-key kkc-length-head))
+ (setq kkc-length-head (1- kkc-length-head)))
+ (goto-char to)
+ (kkc-update-conversion 'all)
+ (kkc-mode)
+ (recursive-edit))
+ (goto-char (overlay-end kkc-overlay-tail))
+ (delete-overlay kkc-overlay-head)
+ (delete-overlay kkc-overlay-tail)
+ (use-local-map previous-local-map)))
+ kkc-canceled)
+
+(defun kkc-terminate ()
+ "Exit from KKC mode by fixing the current conversion."
+ (interactive)
+ (throw 'exit nil))
+
+(defun kkc-non-kkc-command ()
+ "Exit from KKC mode by fixing the current conversion.
+After that, handle the event which invoked this command."
+ (interactive)
+ (setq unread-command-events (list last-input-event))
+ (kkc-terminate))
+
+(defun kkc-cancel ()
+ "Exit from KKC mode by canceling any conversions."
+ (interactive)
+ (setq kkc-canceled (overlay-start kkc-overlay-head))
+ (goto-char kkc-canceled)
+ (delete-region (overlay-start kkc-overlay-head)
+ (overlay-end kkc-overlay-tail))
+ (insert kkc-original-kana)
+ (kkc-terminate))
+
+(defun kkc-first-char-only ()
+ "Select only the first character currently converted."
+ (interactive)
+ (goto-char (overlay-start kkc-overlay-head))
+ (forward-char 1)
+ (delete-region (point) (overlay-end kkc-overlay-tail))
+ (kkc-terminate))
+
+;; Count of successive invocations of `kkc-next'.
+(defvar kkc-next-count nil)
+
+(defun kkc-next ()
+ "Select the next candidate of conversion."
+ (interactive)
+ (if (eq this-command last-command)
+ (setq kkc-next-count (1+ kkc-next-count))
+ (setq kkc-next-count 1))
+ (let ((idx (1+ (car kkc-current-conversions))))
+ (if (< idx 0)
+ (setq idx 1))
+ (if (>= idx (length kkc-current-conversions))
+ (setq idx 0))
+ (setcar kkc-current-conversions idx)
+ (if (> idx 1)
+ (progn
+ (set-nested-alist kkc-current-key kkc-current-conversions
+ kkc-lookup-cache kkc-length-converted)
+ (setq kkc-init-file-flag 'kkc-lookup-cache)))
+ (if (or kkc-current-conversions-width
+ (>= kkc-next-count kkc-show-conversion-list-count))
+ (kkc-show-conversion-list-update))
+ (kkc-update-conversion)))
+
+;; Count of successive invocations of `kkc-next'.
+(defvar kkc-prev-count nil)
+
+(defun kkc-prev ()
+ "Select the previous candidate of conversion."
+ (interactive)
+ (if (eq this-command last-command)
+ (setq kkc-prev-count (1+ kkc-prev-count))
+ (setq kkc-prev-count 1))
+ (let ((idx (1- (car kkc-current-conversions))))
+ (if (< idx 0)
+ (setq idx (1- (length kkc-current-conversions))))
+ (setcar kkc-current-conversions idx)
+ (if (> idx 1)
+ (progn
+ (set-nested-alist kkc-current-key kkc-current-conversions
+ kkc-lookup-cache kkc-length-converted)
+ (setq kkc-init-file-flag 'kkc-lookup-cache)))
+ (if (or kkc-current-conversions-width
+ (>= kkc-prev-count kkc-show-conversion-list-count))
+ (kkc-show-conversion-list-update))
+ (kkc-update-conversion)))
+
+(defun kkc-select-from-list ()
+ "Select one candidate from the list currently shown in echo area."
+ (interactive)
+ (let (idx)
+ (if kkc-current-conversions-width
+ (let ((len (length kkc-show-conversion-list-index-chars))
+ (maxlen (- (aref (aref kkc-current-conversions-width 0) 1)
+ (aref (aref kkc-current-conversions-width 0) 0)))
+ (i 0))
+ (if (> len maxlen)
+ (setq len maxlen))
+ (while (< i len)
+ (if (= (aref kkc-show-conversion-list-index-chars i)
+ last-input-char)
+ (setq idx i i len)
+ (setq i (1+ i))))))
+ (if idx
+ (progn
+ (setcar kkc-current-conversions
+ (+ (aref (aref kkc-current-conversions-width 0) 0) idx))
+ (kkc-show-conversion-list-update)
+ (kkc-update-conversion))
+ (setq unread-command-events (list last-input-event))
+ (kkc-terminate))))
+
+(defun kkc-katakana ()
+ "Convert to Katakana."
+ (interactive)
+ (setcar kkc-current-conversions -1)
+ (kkc-update-conversion 'all))
+
+(defun kkc-hiragana ()
+ "Convert to hiragana."
+ (interactive)
+ (setcar kkc-current-conversions 0)
+ (kkc-update-conversion))
+
+(defun kkc-shorter ()
+ "Make the Kana string to be converted shorter."
+ (interactive)
+ (if (<= kkc-length-head 1)
+ (error "Can't be shorter")
+ (setq kkc-length-head (1- kkc-length-head))
+ (if (> kkc-length-converted kkc-length-head)
+ (let ((len kkc-length-head))
+ (setq kkc-length-converted 0)
+ (while (not (kkc-lookup-key len))
+ (setq len (1- len)))))
+ (kkc-update-conversion 'all)))
+
+(defun kkc-longer ()
+ "Make the Kana string to be converted longer."
+ (interactive)
+ (if (>= kkc-length-head (length kkc-current-key))
+ (error "Can't be longer")
+ (setq kkc-length-head (1+ kkc-length-head))
+ ;; This time, try also entries with postfixes.
+ (kkc-lookup-key kkc-length-head 'postfix)
+ (kkc-update-conversion 'all)))
+
+(defun kkc-next-phrase ()
+ "Fix the currently converted string and try to convert the remaining string."
+ (interactive)
+ (if (>= kkc-length-head (length kkc-current-key))
+ (kkc-terminate)
+ (setq kkc-length-head (- (length kkc-current-key) kkc-length-head))
+ (goto-char (overlay-end kkc-overlay-head))
+ (while (and (< (point) (overlay-end kkc-overlay-tail))
+ (looking-at "\\CH"))
+ (goto-char (match-end 0))
+ (setq kkc-length-head (1- kkc-length-head)))
+ (if (= kkc-length-head 0)
+ (kkc-terminate)
+ (let ((newkey (make-vector kkc-length-head 0))
+ (idx (- (length kkc-current-key) kkc-length-head))
+ (i 0))
+ ;; For the moment, (setq kkc-original-kana (concat newkey))
+ ;; doesn't work.
+ (setq kkc-original-kana "")
+ (while (< i kkc-length-head)
+ (aset newkey i (aref kkc-current-key (+ idx i)))
+ (setq kkc-original-kana
+ (concat kkc-original-kana (char-to-string (aref newkey i))))
+ (setq i (1+ i)))
+ (setq kkc-current-key newkey)
+ (setq kkc-length-converted 0)
+ (while (and (not (kkc-lookup-key kkc-length-head))
+ (> kkc-length-head 1))
+ (setq kkc-length-head (1- kkc-length-head)))
+ (let ((pos (point))
+ (tail (overlay-end kkc-overlay-tail)))
+ (move-overlay kkc-overlay-head pos tail)
+ (move-overlay kkc-overlay-tail tail tail))
+ (kkc-update-conversion 'all)))))
+
+;; We'll show users a list of available conversions in echo area with
+;; index numbers so that users can select one conversion with the
+;; number.
+
+;; Set `kkc-current-conversions-width'.
+(defun kkc-setup-current-conversions-width ()
+ (let ((convs (cdr kkc-current-conversions))
+ (len (length kkc-current-conversions))
+ (idx 1))
+ (setq kkc-current-conversions-width (make-vector len nil))
+ ;; To tell `kkc-show-conversion-list-update' to generate
+ ;; message from scratch.
+ (aset kkc-current-conversions-width 0 (vector len -2 nil))
+ ;; Fill the remaining slots.
+ (while convs
+ (aset kkc-current-conversions-width idx
+ (+ (string-width (car convs)) 4))
+ (setq convs (cdr convs)
+ idx (1+ idx)))))
+
+(defun kkc-show-conversion-list-or-next-group ()
+ "Show list of available conversions in echo area with index numbers.
+If the list is already shown, show the next group of conversions,
+and change the current conversion to the first one in the group."
+ (interactive)
+ (if (< (length kkc-current-conversions) 3)
+ (error "No alternative"))
+ (if kkc-current-conversions-width
+ (let ((next-idx (aref (aref kkc-current-conversions-width 0) 1)))
+ (if (< next-idx (length kkc-current-conversions-width))
+ (setcar kkc-current-conversions next-idx)
+ (setcar kkc-current-conversions 1))
+ (kkc-show-conversion-list-update)
+ (kkc-update-conversion))
+ (kkc-setup-current-conversions-width)
+ (kkc-show-conversion-list-update)))
+
+(defun kkc-show-conversion-list-or-prev-group ()
+ "Show list of available conversions in echo area with index numbers.
+If the list is already shown, show the previous group of conversions,
+and change the current conversion to the last one in the group."
+ (interactive)
+ (if (< (length kkc-current-conversions) 3)
+ (error "No alternative"))
+ (if kkc-current-conversions-width
+ (let ((this-idx (aref (aref kkc-current-conversions-width 0) 0)))
+ (if (> this-idx 1)
+ (setcar kkc-current-conversions (1- this-idx))
+ (setcar kkc-current-conversions
+ (1- (length kkc-current-conversions-width))))
+ (kkc-show-conversion-list-update)
+ (kkc-update-conversion))
+ (kkc-setup-current-conversions-width)
+ (kkc-show-conversion-list-update)))
+
+;; Update the conversion list shown in echo area.
+(defun kkc-show-conversion-list-update ()
+ (or kkc-current-conversions-width
+ (kkc-setup-current-conversions-width))
+ (let* ((current-idx (car kkc-current-conversions))
+ (first-slot (aref kkc-current-conversions-width 0))
+ (this-idx (aref first-slot 0))
+ (next-idx (aref first-slot 1))
+ (msg (aref first-slot 2)))
+ (if (< current-idx this-idx)
+ ;; The currently selected conversion is before the list shown
+ ;; previously. We must start calculation of message width
+ ;; from the start again.
+ (setq this-idx 1 msg nil)
+ (if (>= current-idx next-idx)
+ ;; The currently selected conversion is after the list shown
+ ;; previously. We start calculation of message width from
+ ;; the conversion next of TO.
+ (setq this-idx next-idx msg nil)
+ ;; The current conversion is in MSG. Just clear brackets
+ ;; around index number.
+ (if (string-match "<.>" msg)
+ (progn
+ (aset msg (match-beginning 0) ?\ )
+ (aset msg (1- (match-end 0)) ?\ )))))
+ (if (not msg)
+ (let ((len (length kkc-current-conversions))
+ (max-width (window-width (minibuffer-window)))
+ (width-table kkc-current-conversions-width)
+ (width 0)
+ (idx this-idx)
+ l)
+ (while (< idx current-idx)
+ (if (<= (+ width (aref width-table idx)) max-width)
+ (setq width (+ width (aref width-table idx)))
+ (setq this-idx idx width (aref width-table idx)))
+ (setq idx (1+ idx)
+ l (cdr l)))
+ (aset first-slot 0 this-idx)
+ (while (and (< idx len)
+ (<= (+ width (aref width-table idx)) max-width))
+ (setq width (+ width (aref width-table idx))
+ idx (1+ idx)
+ l (cdr l)))
+ (aset first-slot 1 (setq next-idx idx))
+ (setq l (nthcdr this-idx kkc-current-conversions))
+ (setq msg "")
+ (setq idx this-idx)
+ (while (< idx next-idx)
+ (setq msg (format "%s %c %s "
+ msg
+ (aref kkc-show-conversion-list-index-chars
+ (- idx this-idx))
+ (car l)))
+ (setq idx (1+ idx)
+ l (cdr l)))
+ (aset first-slot 2 msg)))
+ (if (> current-idx 0)
+ (progn
+ ;; Highlight the current conversion by brackets.
+ (string-match (format " \\(%c\\) "
+ (aref kkc-show-conversion-list-index-chars
+ (- current-idx this-idx)))
+ msg)
+ (aset msg (match-beginning 0) ?<)
+ (aset msg (1- (match-end 0)) ?>)))
+ (message "%s" msg)))
+
+;; Update the conversion area with the latest conversion selected.
+;; ALL if non nil means to update the whole area, else update only
+;; inside quail-overlay-head.
+
+(defun kkc-update-conversion (&optional all)
+ (goto-char (overlay-start kkc-overlay-head))
+ (cond ((= (car kkc-current-conversions) 0) ; Hiragana
+ (let ((i 0))
+ (while (< i kkc-length-converted)
+ (insert (aref kkc-current-key i))
+ (setq i (1+ i)))))
+ ((= (car kkc-current-conversions) -1) ; Katakana
+ (let ((i 0))
+ (while (< i kkc-length-converted)
+ (insert (japanese-katakana (aref kkc-current-key i)))
+ (setq i (1+ i)))))
+ (t
+ (insert (nth (car kkc-current-conversions) kkc-current-conversions))))
+ (delete-region (point) (overlay-start kkc-overlay-tail))
+ (if all
+ (let ((len (length kkc-current-key))
+ (i kkc-length-converted))
+ (delete-region (overlay-start kkc-overlay-tail)
+ (overlay-end kkc-overlay-head))
+ (while (< i kkc-length-head)
+ (if (= (car kkc-current-conversions) -1)
+ (insert (japanese-katakana (aref kkc-current-key i)))
+ (insert (aref kkc-current-key i)))
+ (setq i (1+ i)))
+ (let ((pos (point)))
+ (while (< i len)
+ (insert (aref kkc-current-key i))
+ (setq i (1+ i)))
+ (move-overlay kkc-overlay-head
+ (overlay-start kkc-overlay-head) pos)
+ (delete-region (point) (overlay-end kkc-overlay-tail)))))
+ (goto-char (overlay-end kkc-overlay-tail)))
+
+;;
+(provide 'kkc)
+
+;; kkc.el ends here
--- /dev/null
+;;; mule-cmds.el --- Commands for mulitilingual environment
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: mule, multilingual
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Code:
+
+;;; MULE related key bindings and menus.
+
+(defvar mule-keymap (make-sparse-keymap "MULE")
+ "Keymap for MULE (Multilingual environment) specific commands.")
+(fset 'mule-prefix mule-keymap)
+
+;; Keep "C-x C-k ..." for mule specific commands.
+(define-key ctl-x-map "\C-k" 'mule-prefix)
+
+(define-key global-map [menu-bar mule] (cons "Mule" mule-keymap))
+
+(setq menu-bar-final-items (cons 'mule menu-bar-final-items))
+
+(defvar mule-describe-language-support-map
+ (make-sparse-keymap "Describe Language Support"))
+(fset 'mule-describe-language-support-prefix
+ mule-describe-language-support-map)
+
+(define-key mule-keymap "m" 'toggle-enable-multibyte-characters)
+(define-key mule-keymap "f" 'set-buffer-file-coding-system)
+(define-key mule-keymap "t" 'set-terminal-coding-system)
+(define-key mule-keymap "k" 'set-keyboard-coding-system)
+(define-key mule-keymap "p" 'set-current-process-coding-system)
+(define-key mule-keymap "i" 'select-input-method)
+
+(define-key help-map "\C-L" 'describe-language-support)
+(define-key help-map "\C-\\" 'describe-input-method)
+(define-key help-map "C" 'describe-current-coding-system)
+(define-key help-map "h" 'view-hello-file)
+
+(define-key mule-keymap [set-process-coding-system]
+ '(" ... of process" . set-current-process-coding-system))
+(define-key mule-keymap [set-keyboard-coding-system]
+ '(" ... of keyboard" . set-keyboard-coding-system))
+(define-key mule-keymap [set-terminal-coding-system]
+ '(" ... of terminal" . set-terminal-coding-system))
+(define-key mule-keymap [set-buffer-file-coding-system]
+ '(" ... of visiting file" . set-buffer-file-coding-system))
+(define-key mule-keymap [separator-mule]
+ '("Setting coding systems"))
+(define-key mule-keymap [describe-current-coding-system]
+ '("Describe current coding systems" . describe-current-coding-system))
+(define-key mule-keymap [describe-language-support]
+ '("Describe language support" . mule-describe-language-support-prefix))
+(define-key mule-keymap [view-hello-file]
+ '("Show many languages" . view-hello-file))
+(define-key mule-keymap [describe-input-method]
+ '("Describe input method" . describe-input-method))
+(define-key mule-keymap [select-input-method]
+ '("Select input method" . select-input-method))
+(define-key mule-keymap [toggle-input-method]
+ '("Toggle input method" . toggle-input-method))
+(define-key mule-keymap [toggle-mule]
+ '("Toggle MULE" . toggle-enable-multibyte-characters))
+
+;; These are meaningless when running under X.
+(put 'set-keyboard-coding-system 'menu-enable
+ '(null window-system))
+(put 'set-terminal-coding-system 'menu-enable
+ '(null window-system))
+
+
+;; This should be a single character key binding because users use it
+;; very frequently while editing multilingual text. Now we can use
+;; only two such keys: "\C-\\" and "\C-^", but the latter is not
+;; convenient because it requires shifting on most keyboards. An
+;; alternative is "\C-\]" which is now bound to `abort-recursive-edit'
+;; but it won't be used that frequently.
+(define-key global-map "\C-\\" 'toggle-input-method)
+
+(defun toggle-enable-multibyte-characters (&optional arg)
+ "Change whether this buffer enables multibyte characters.
+With arg, make them enable iff arg is positive."
+ (interactive "P")
+ (setq enable-multibyte-characters
+ (if (null arg) (null enable-multibyte-characters)
+ (> (prefix-numeric-value arg) 0)))
+ (force-mode-line-update))
+
+(defun view-hello-file ()
+ "Display the HELLO file which list up many languages and characters."
+ (interactive)
+ (find-file-read-only (expand-file-name "HELLO" data-directory)))
+
+\f
+;;; Language support staffs.
+
+(defvar primary-language "English"
+ "Name of a user's primary language.
+Emacs provide various language supports based on this variable.")
+
+(defvar language-info-alist nil
+ "Alist of language names vs the corresponding information of various kind.
+Each element looks like:
+ (LANGUAGE-NAME . ((KEY . INFO) ...))
+where LANGUAGE-NAME is a string,
+KEY is a symbol denoting the kind of information,
+INFO is any Lisp object which contains the actual information related
+to KEY.")
+
+(defun get-language-info (language-name key)
+ "Return the information for LANGUAGE-NAME of the kind KEY.
+LANGUAGE-NAME is a string.
+KEY is a symbol denoting the kind of required information."
+ (let ((lang-slot (assoc language-name language-info-alist)))
+ (if lang-slot
+ (cdr (assq key (cdr lang-slot))))))
+
+;; Return a lambda form which calls `describe-language-support' with
+;; argument LANG.
+(defun build-describe-language-support-function (lang)
+ `(lambda ()
+ (interactive)
+ (describe-language-support ,lang)))
+
+(defun set-language-info (language-name key info)
+ "Set for LANGUAGE-NAME the information INFO under KEY.
+LANGUAGE-NAME is a string
+KEY is a symbol denoting the kind of information.
+INFO is any Lisp object which contains the actual information.
+
+Currently, the following KEYs are used by Emacs:
+charset: list of symbols whose values are charsets specific to the language.
+coding-system: list of coding systems specific to the langauge.
+setup-function: see the documentation of `set-language-envrionment'.
+tutorial: a tutorial file name written in the language.
+sample-text: one line short text containing characters of the language.
+documentation: a docstring describing how the language is supported,
+ or a fuction to call to describe it,
+ or t which means call `describe-language-support' to describe it.
+input-method: alist of input method names for the language vs information
+ for activating them. Use `register-input-method' (which see)
+ to add a new input method to the alist.
+
+Emacs will use more KEYs in the future. To avoid the conflition, users
+should use prefix \"user-\" in the name of KEY."
+ (let (lang-slot key-slot)
+ (setq lang-slot (assoc language-name language-info-alist))
+ (if (null lang-slot) ; If no slot for the language, add it.
+ (setq lang-slot (list language-name)
+ language-info-alist (cons lang-slot language-info-alist)))
+ (setq key-slot (assq key lang-slot))
+ (if (null key-slot) ; If no slot for the key, add it.
+ (progn
+ (setq key-slot (list key))
+ (setcdr lang-slot (cons key-slot (cdr lang-slot)))))
+ (setcdr key-slot info)
+ ;; Setup menu.
+ (if (eq key 'documentation)
+ (define-key mule-describe-language-support-map
+ (vector (intern language-name))
+ (cons language-name
+ (build-describe-language-support-function language-name))))
+ ))
+
+(defun set-language-info-alist (language-name alist)
+ "Set for LANGUAGE-NAME the information in ALIST.
+ALIST is an alist of KEY and INFO. See the documentation of
+`set-langauge-info' for the meanings of KEY and INFO."
+ (while alist
+ (set-language-info language-name (car (car alist)) (cdr (car alist)))
+ (setq alist (cdr alist))))
+
+(defun read-language-name (key prompt &optional initial-input)
+ "Read language name which has information for KEY, prompting with PROMPT."
+ (let* ((completion-ignore-case t)
+ (name (completing-read prompt
+ language-info-alist
+ (function (lambda (elm) (assq key elm)))
+ t
+ initial-input)))
+ ;; In spite of the documentation, completing-read returns null
+ ;; string instead of nil if input is null.
+ (and (> (length name) 0) name)))
+\f
+;;; Multilingual input methods.
+
+(defvar current-input-method nil
+ "The current input method for multilingual text.
+The value is a cons of language name and input method name.
+If nil, it means no input method is activated now.")
+(make-variable-buffer-local 'current-input-method)
+(put 'current-input-method 'permanent-local t)
+
+(defvar current-input-method-title nil
+ "Title string of the current input method shown in mode line.
+Every input method should set this an appropriate value when activated.")
+(make-variable-buffer-local 'current-input-method-title)
+(put 'current-input-method-title 'permanent-local t)
+
+(defvar default-input-method nil
+ "Default input method.
+The default input method is the one activated automatically by the command
+`toggle-input-method' (\\[toggle-input-method]).
+The value is a cons of language name and input method name.")
+
+(defvar default-input-method-title nil
+ "Title string of the default input method.")
+
+(defvar previous-input-method nil
+ "Input method selected previously.
+This is the one selected before the current input method is selected.
+See also the documentation of `default-input-method'.")
+
+(defvar inactivate-current-input-method-function nil
+ "Function to call for inactivating the current input method.
+Every input method should set this to an appropriate value when activated.
+This function is called with no argument.")
+(make-variable-buffer-local 'inactivate-current-input-method-function)
+(put 'inactivate-current-input-method-function 'permanent-local t)
+
+(defvar describe-current-input-method-function nil
+ "Function to call for describing the current input method.
+This function is called with no argument.")
+(make-variable-buffer-local 'describe-current-input-method-function)
+(put 'describe-current-input-method-function 'permanent-local t)
+
+(defun register-input-method (language-name input-method)
+ "Register INPUT-METHOD as an input method of LANGUAGE-NAME.
+LANGUAGE-NAME is a string.
+INPUT-METHOD is a list of the form:
+ (METHOD-NAME ACTIVATE-FUNC ARG ...)
+where METHOD-NAME is the name of this method,
+ACTIVATE-FUNC is the function to call for activating this method.
+Arguments for the function are METHOD-NAME and ARGs."
+ (let ((slot (get-language-info language-name 'input-method))
+ method-slot)
+ (if (null slot)
+ (set-language-info language-name 'input-method (list input-method))
+ (setq method-slot (assoc (car input-method) slot))
+ (if method-slot
+ (setcdr method-slot (cdr input-method))
+ (set-language-info language-name 'input-method
+ (cons input-method slot))))))
+
+(defun read-language-and-input-method-name ()
+ "Read a language names and the corresponding input method from a minibuffer.
+Return a cons of those names."
+ (let ((language-name (read-language-name
+ 'input-method
+ "Language: "
+ (if previous-input-method
+ (cons (car previous-input-method) 0)))))
+ (if (null language-name)
+ (error "No input method for the specified language"))
+ (let* ((completion-ignore-case t)
+ (key-slot
+ (assq 'input-method
+ (cdr (assoc language-name language-info-alist))))
+ (method-name
+ (completing-read "Input method: " (cdr key-slot) nil t
+ (if (and previous-input-method
+ (string= language-name
+ (car previous-input-method)))
+ (cons (cdr previous-input-method) 0)))))
+ ;; In spite of the documentation, completing-read returns
+ ;; null string instead of nil if input is null.
+ (if (= (length method-name) 0)
+ (error "No input method specified"))
+ (list language-name method-name))))
+
+(defun set-default-input-method (language-name method-name)
+ "Set the default input method to METHOD-NAME for inputting LANGUAGE-NAME.
+The default input method is the one activated automatically by the command
+`toggle-input-method' (\\[toggle-input-method]).
+This doesn't affect the currently activated input method."
+ (interactive (read-language-and-input-method-name))
+ (let* ((key-slot (get-language-info language-name 'input-method))
+ (method-slot (assoc method-name key-slot)))
+ (if (null method-slot)
+ (error "No input method `%s' for %s" method-name language-name))
+ (setq default-input-method (cons language-name method-name))))
+
+(defun select-input-method (language-name method-name)
+ "Select and activate input method METHOD-NAME for inputting LANGUAGE-NAME.
+The information for activating METHOD-NAME is stored
+in `language-info-alist' under the key 'input-method.
+The format of the information has the form:
+ ((METHOD-NAME ACTIVATE-FUNC ARG ...) ...)
+where ACTIVATE-FUNC is a function to call for activating this method.
+Arguments for the function are METHOD-NAME and ARGs."
+ (interactive (read-language-and-input-method-name))
+ (let* ((key-slot (get-language-info language-name 'input-method))
+ (method-slot (assoc method-name key-slot)))
+ (if (null method-slot)
+ (error "No input method `%s' for %s" method-name language-name))
+ (if current-input-method
+ (progn
+ (if (not (equal previous-input-method current-input-method))
+ (setq previous-input-method current-input-method))
+ (funcall inactivate-current-input-method-function)))
+ (setq method-slot (cdr method-slot))
+ (apply (car method-slot) method-name (cdr method-slot))
+ (setq default-input-method
+ (setq current-input-method (cons language-name method-name)))
+ (setq default-input-method-title current-input-method-title)
+ (setq current-input-method default-input-method)))
+
+(defun toggle-input-method (&optional arg)
+ "Toggle whether a multilingual input method is activated in this buffer.
+With arg, activate an input method specified interactively.
+Without arg, the method being activated is the one selected most recently,
+ but if no input method has ever been selected, select one interactively."
+ (interactive "P")
+ (if arg
+ (call-interactively 'select-input-method)
+ (if (null current-input-method)
+ (if default-input-method
+ (select-input-method (car default-input-method)
+ (cdr default-input-method))
+ (call-interactively 'select-input-method))
+ (funcall inactivate-current-input-method-function)
+ (setq current-input-method nil))))
+
+(defun describe-input-method ()
+ "Describe the current input method."
+ (interactive)
+ (if current-input-method
+ (if (and (symbolp describe-current-input-method-function)
+ (fboundp describe-current-input-method-function))
+ (funcall describe-current-input-method-function)
+ (message "No way to describe the current input method `%s'"
+ (cdr current-input-method))
+ (ding))
+ (message "No input method is activated now")
+ (ding)))
+
+(defun read-multilingual-string (prompt &optional initial-input
+ language-name method-name)
+ "Read a multilingual string from minibuffer, prompting with string PROMPT.
+The input method selected last time is activated in minibuffer.
+If non-nil, second arg INITIAL-INPUT is a string to insert before reading.
+Optional 3rd and 4th arguments LANGUAGE-NAME and METHOD-NAME specify
+ the input method to be activated instead of the one selected last time."
+ (let ((minibuffer-setup-hook '(toggle-input-method))
+ (default-input-method default-input-method))
+ (if (and language-name method-name)
+ (set-default-input-method language-name method-name))
+ (read-string prompt initial-input)))
+
+;; Variables to control behavior of input methods. All input methods
+;; should react to these variables.
+
+(defvar input-method-tersely-flag nil
+ "*If this flag is non-nil, input method works rather tersely.
+
+For instance, Quail input method does not show guidance buffer while
+inputting at minibuffer if this flag is t.")
+
+(defvar input-method-activate-hook nil
+ "Normal hook run just after an input method is activated.")
+
+(defvar input-method-inactivate-hook nil
+ "Normal hook run just after an input method is inactivated.")
+
+(defvar input-method-after-insert-chunk-hook nil
+ "Normal hook run just after an input method insert some chunk of text.")
+
+\f
+;;; Language specific setup functions.
+(defun set-language-environment (language-name)
+ "Setup a user's environment for LANGUAGE-NAME.
+
+To setup, a fucntion returned by:
+ (get-language-info LANGUAGE-NAME 'setup-function)
+is called."
+ (interactive (list (read-language-name 'setup-function "Language: ")))
+ (let (func)
+ (if (or (null language-name)
+ (null (setq func
+ (get-language-info language-name 'setup-function))))
+ (error "No way to setup environment for the specified language"))
+ (funcall func)))
+
+;; Print all arguments with `princ', then print "\n".
+(defsubst princ-list (&rest args)
+ (while args (princ (car args)) (setq args (cdr args)))
+ (princ "\n"))
+
+(defun describe-language-support (language-name)
+ "Show documentation about how Emacs supports LANGUAGE-NAME."
+ (interactive (list (read-language-name 'documentation "Language: ")))
+ (let (doc)
+ (if (or (null language-name)
+ (null (setq doc
+ (get-language-info language-name 'documentation))))
+ (error "No documentation for the specified language"))
+ (with-output-to-temp-buffer "*Help*"
+ (if (not (eq doc t))
+ (cond ((stringp doc)
+ (princ doc))
+ ((and (symbolp doc) (fboundp doc))
+ (funcall doc))
+ (t
+ (error "Invalid documentation data for %s" language-name)))
+ (princ-list "List of items specific to "
+ language-name
+ " environment")
+ (princ "-----------------------------------------------------------\n")
+ (let ((str (get-language-info language-name 'sample-text)))
+ (if (stringp str)
+ (progn
+ (princ "<sample text>\n")
+ (princ-list " " str))))
+ (princ "<input methods>\n")
+ (let ((l (get-language-info language-name 'input-method)))
+ (while l
+ (princ-list " " (car (car l)))
+ (setq l (cdr l))))
+ (princ "<character sets>\n")
+ (let ((l (get-language-info language-name 'charset)))
+ (if (null l)
+ (princ-list " nothing specific to " language-name)
+ (while l
+ (princ-list " " (car l)
+ (format ":%3d:\n\t" (charset-id (car l)))
+ (charset-description (car l)))
+ (setq l (cdr l)))))
+ (princ "<coding systems>\n")
+ (let ((l (get-language-info language-name 'coding-system)))
+ (if (null l)
+ (princ-list " nothing specific to " language-name)
+ (while l
+ (princ-list " " (car l) ":\n\t"
+ (coding-system-docstring (car l)))
+ (setq l (cdr l)))))))))
+\f
+;;; Charset property
+
+(defsubst get-charset-property (charset propname)
+ "Return the value of CHARSET's PROPNAME property.
+This is the last value stored with
+`(put-charset-property CHARSET PROPNAME VALUE)'."
+ (plist-get (charset-plist charset) propname))
+
+(defsubst put-charset-property (charset propname value)
+ "Store CHARSETS's PROPNAME property with value VALUE.
+It can be retrieved with `(get-charset-property CHARSET PROPNAME)'."
+ (set-charset-plist charset
+ (plist-put (charset-plist charset) propname value)))
+
+;;; Character code property
+(put 'char-code-property-table 'char-table-extra-slots 0)
+
+(defvar char-code-property-table
+ (make-char-table 'char-code-property-table)
+ "Char-table containing a property list of each character code.
+
+See also the documentation of `get-char-code-property' and
+`put-char-code-property'")
+
+(defun get-char-code-property (char propname)
+ "Return the value of CHAR's PROPNAME property in `char-code-property-table'."
+ (let ((plist (aref char-code-property-table char)))
+ (if (listp plist)
+ (car (cdr (memq propname plist))))))
+
+(defun put-char-code-property (char propname value)
+ "Store CHAR's PROPNAME property with VALUE in `char-code-property-table'.
+It can be retrieved with `(get-char-code-property CHAR PROPNAME)'."
+ (let ((plist (aref char-code-property-table char)))
+ (if plist
+ (let ((slot (memq propname plist)))
+ (if slot
+ (setcar (cdr slot) value)
+ (nconc plist (list propname value))))
+ (aset char-code-property-table char (list propname value)))))
+
+;;; mule-cmds.el ends here
--- /dev/null
+;; mule-diag.el -- show diagnosis of multilingual environment (MULE)
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: multilingual, charset, coding system, fontset, diagnosis
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; General utility function
+
+;; Print all arguments with single space separator in one line.
+(defun print-list (&rest args)
+ (while (cdr args)
+ (if (car args)
+ (progn (princ (car args)) (princ " ")))
+ (setq args (cdr args)))
+ (princ (car args))
+ (princ "\n"))
+
+;;; CHARSET
+
+;;;###autoload
+(defun list-character-sets ()
+ "Display a list of all charsets."
+ (interactive)
+ (with-output-to-temp-buffer "*Help*"
+ (print-character-sets)))
+
+(defvar charset-other-info-func nil)
+
+(defun print-character-sets ()
+ "Print information on all charsets in a machine readable format."
+ (princ "\
+#########################
+## LIST OF CHARSETS
+## Each line corresponds to one charset.
+## The following attributes are listed in this order
+## separated by a colon `:' in one line.
+## CHARSET-SYMBOL-NAME,
+## CHARSET-ID,
+## DIMENSION (1 or 2)
+## CHARS (94 or 96)
+## BYTES (of multibyte form: 1, 2, 3, or 4),
+## WIDTH (occupied column numbers: 1 or 2),
+## DIRECTION (0:left-to-right, 1:right-to-left),
+## ISO-FINAL-CHAR (character code of ISO-2022's final character)
+## ISO-GRAPHIC-PLANE (ISO-2022's graphic plane, 0:GL, 1:GR)
+## DESCRIPTION (describing string of the charset)
+")
+ (let ((charsets charset-list)
+ charset)
+ (while charsets
+ (setq charset (car charsets))
+ (princ (format "%s:%03d:%d:%d:%d:%d:%d:%d:%d:%s\n"
+ charset
+ (charset-id charset)
+ (charset-dimension charset)
+ (charset-chars charset)
+ (charset-bytes charset)
+ (charset-width charset)
+ (charset-direction charset)
+ (charset-iso-final-char charset)
+ (charset-iso-graphic-plane charset)
+ (charset-description charset)))
+ (setq charsets (cdr charsets)))))
+
+\f
+;;; CODING-SYSTEM
+
+;; Print information of designation of each graphic register in FLAGS
+;; in human readable format. See the documentation of
+;; `make-coding-system' for the meaning of FLAGS.
+(defun print-designation (flags)
+ (let ((graphic-register 0)
+ charset)
+ (while (< graphic-register 4)
+ (setq charset (aref flags graphic-register))
+ (princ (format
+ " G%d -- %s\n"
+ graphic-register
+ (cond ((null charset)
+ "never used")
+ ((eq charset t)
+ "no initial designation, and used by any charsets")
+ ((symbolp charset)
+ (format "%s:%s"
+ charset (charset-description charset)))
+ ((listp charset)
+ (if (charsetp (car charset))
+ (format "%s:%s, and also used by the followings:"
+ (car charset)
+ (charset-description (car charset)))
+ "no initial designation, and used by the followings:"))
+ (t
+ "invalid designation information"))))
+ (if (listp charset)
+ (progn
+ (setq charset (cdr charset))
+ (while charset
+ (cond ((eq (car charset) t)
+ (princ "\tany other charsets\n"))
+ ((charsetp (car charset))
+ (princ (format "\t%s:%s\n"
+ (car charset)
+ (charset-description (car charset)))))
+ (t
+ "invalid designation information"))
+ (setq charset (cdr charset)))))
+ (setq graphic-register (1+ graphic-register)))))
+
+;;;###autoload
+(defun describe-coding-system (coding-system)
+ "Display information of CODING-SYSTEM."
+ (interactive "zCoding-system: ")
+ (check-coding-system coding-system)
+ (with-output-to-temp-buffer "*Help*"
+ (let ((coding-vector (coding-system-vector coding-system)))
+ (princ "Coding-system ")
+ (princ coding-system)
+ (princ " [")
+ (princ (char-to-string (coding-vector-mnemonic coding-vector)))
+ (princ "]: \n")
+ (princ " ")
+ (princ (coding-vector-docstring coding-vector))
+ (princ "\nType: ")
+ (let ((type (coding-vector-type coding-vector))
+ (flags (coding-vector-flags coding-vector)))
+ (princ type)
+ (princ ", which means ")
+ (cond ((eq type nil)
+ (princ "do no conversion."))
+ ((eq type t)
+ (princ "do automatic conversion."))
+ ((eq type 0)
+ (princ "Emacs internal multibyte form."))
+ ((eq type 1)
+ (princ "Shift-JIS (MS-KANJI)."))
+ ((eq type 2)
+ (princ "a variant of ISO-2022.\n")
+ (princ "Initial designations:\n")
+ (print-designation flags)
+ (princ "Other Form: \n")
+ (princ (if (aref flags 4) "short-form" "long-form"))
+ (if (aref flags 5) (princ ", ASCII@EOL"))
+ (if (aref flags 6) (princ ", ASCII@CNTL"))
+ (princ (if (aref flags 7) ", 7-bit" ", 8-bit"))
+ (if (aref flags 8) (princ ", use-locking-shift"))
+ (if (aref flags 9) (princ ", use-single-shift"))
+ (if (aref flags 10) (princ ", use-roman"))
+ (if (aref flags 10) (princ ", use-old-jis"))
+ (if (aref flags 11) (princ ", no-ISO6429"))
+ (princ "."))
+ ((eq type 3)
+ (princ "Big5."))
+ ((eq type 4)
+ (princ "do conversion by CCL program."))
+ (t (princ "invalid coding-system."))))
+ (princ "\nEOL-Type: ")
+ (let ((eol-type (coding-system-eoltype coding-system)))
+ (cond ((vectorp eol-type)
+ (princ "Automatic selection from ")
+ (princ eol-type)
+ (princ "\n"))
+ ((or (null eol-type) (eq eol-type 0)) (princ "LF\n"))
+ ((eq eol-type 1) (princ "CRLF\n"))
+ ((eq eol-type 2) (princ "CR\n"))
+ (t (princ "invalid\n"))))
+ )))
+
+;;;###autoload
+(defun describe-current-coding-system-briefly ()
+ "Display coding systems currently used in a brief format in mini-buffer.
+
+The format is \"current: [FKTPp=........] default: [FPp=......]\",
+where mnemonics of the following coding systems come in this order
+at the place of `...':
+ buffer-file-coding-system (of the current buffer)
+ eol-type of buffer-file-coding-system (of the current buffer)
+ keyboard-coding-system
+ terminal-coding-system
+ process-coding-system for read (of the current buffer, if any)
+ eol-type of process-coding-system for read (of the current buffer, if any)
+ process-coding-system for write (of the current buffer, if any)
+ eol-type of process-coding-system for write (of the current buffer, if any)
+ default buffer-file-coding-system
+ eol-type of default buffer-file-coding-system
+ default process-coding-system for read
+ default eol-type of process-coding-system for read
+ default process-coding-system for write
+ default eol-type of process-coding-system"
+ (interactive)
+ (let* ((proc (get-buffer-process (current-buffer)))
+ (process-coding-systems (if proc (process-coding-system proc))))
+ (message
+ "current: [FKTPp=%c%c%c%c%c%c%c%c] default: [FPp=%c%c%c%c%c%c]"
+ (coding-system-mnemonic buffer-file-coding-system)
+ (coding-system-eoltype-mnemonic buffer-file-coding-system)
+ (coding-system-mnemonic (keyboard-coding-system))
+ (coding-system-mnemonic (terminal-coding-system))
+ (coding-system-mnemonic (car process-coding-systems))
+ (coding-system-eoltype-mnemonic (car process-coding-systems))
+ (coding-system-mnemonic (cdr process-coding-systems))
+ (coding-system-eoltype-mnemonic (cdr process-coding-systems))
+ (coding-system-mnemonic (default-value 'buffer-file-coding-system))
+ (coding-system-eoltype-mnemonic (default-value 'buffer-file-coding-system))
+ (coding-system-mnemonic (car default-process-coding-system))
+ (coding-system-eoltype-mnemonic (car default-process-coding-system))
+ (coding-system-mnemonic (cdr default-process-coding-system))
+ (coding-system-eoltype-mnemonic (cdr default-process-coding-system))
+ )))
+
+;; Print symbol name and mnemonics of CODING-SYSTEM by `princ'.
+(defsubst print-coding-system-briefly (coding-system)
+ (print-list ":"
+ coding-system
+ (format "[%c%c]"
+ (coding-system-mnemonic coding-system)
+ (coding-system-eoltype-mnemonic coding-system))))
+
+;;;###autoload
+(defun describe-current-coding-system ()
+ "Display coding systems currently used in a detailed format."
+ (interactive)
+ (with-output-to-temp-buffer "*Help*"
+ (let* ((proc (get-buffer-process (current-buffer)))
+ (process-coding-systems (if proc (process-coding-system proc))))
+ (princ "Current:\n buffer-file-coding-system")
+ (print-coding-system-briefly buffer-file-coding-system)
+ (princ " keyboard-coding-system")
+ (print-coding-system-briefly (keyboard-coding-system))
+ (princ " terminal-coding-system")
+ (print-coding-system-briefly (terminal-coding-system))
+ (if process-coding-systems
+ (progn (princ " process-coding-system (read)")
+ (print-coding-system-briefly (car process-coding-systems))
+ (princ " process-coding-system (write)")
+ (print-coding-system-briefly (cdr process-coding-systems))))
+ (princ "Default:\n buffer-file-coding-system")
+ (print-coding-system-briefly (default-value 'buffer-file-coding-system))
+ (princ " process-coding-system (read)")
+ (print-coding-system-briefly (car default-process-coding-system))
+ (princ " process-coding-system (write)")
+ (print-coding-system-briefly (cdr default-process-coding-system))
+ (princ "coding-system-alist:\n")
+ (pp coding-system-alist))
+ (let ((l coding-category-list))
+ (princ "\nCoding categories (in the order of priority):\n")
+ (while l
+ (princ (format "%s -> %s\n" (car l) (symbol-value (car l))))
+ (setq l (cdr l))))))
+
+;; Print detailed information on CODING-SYSTEM.
+(defun print-coding-system (coding-system)
+ (let ((type (coding-system-type coding-system))
+ (eol-type (coding-system-eoltype coding-system))
+ (flags (coding-system-flags coding-system)))
+ (princ (format "%s:%s:%c:%d:"
+ coding-system
+ type
+ (coding-system-mnemonic coding-system)
+ (if (integerp eol-type) eol-type 3)))
+ (cond ((eq type 2) ; ISO-2022
+ (let ((idx 0)
+ charset)
+ (while (< idx 4)
+ (setq charset (aref flags idx))
+ (cond ((null charset)
+ (princ -1))
+ ((eq charset t)
+ (princ -2))
+ ((charsetp charset)
+ (princ charset))
+ ((listp charset)
+ (princ "(")
+ (princ (car charset))
+ (setq charset (cdr charset))
+ (while charset
+ (princ ",")
+ (princ (car charset))
+ (setq charset (cdr charset)))
+ (princ ")")))
+ (princ ",")
+ (setq idx (1+ idx)))
+ (while (< idx 12)
+ (princ (if (aref flags idx) 1 0))
+ (princ ",")
+ (setq idx (1+ idx)))
+ (princ (if (aref flags idx) 1 0))))
+ ((eq type 4) ; CCL
+ (let (i len)
+ (setq i 0 len (length (car flags)))
+ (while (< i len)
+ (princ (format " %x" (aref (car flags) i)))
+ (setq i (1+ i)))
+ (princ ",")
+ (setq i 0 len (length (cdr flags)))
+ (while (< i len)
+ (princ (format " %x" (aref (cdr flags) i)))
+ (setq i (1+ i)))))
+ (t (princ 0)))
+ (princ ":")
+ (princ (coding-system-docstring coding-system))
+ (princ "\n")))
+
+(defun list-coding-systems ()
+ "Print information on all coding systems in a machine readable format."
+ (with-output-to-temp-buffer "*Help*"
+ (princ "\
+#########################
+## LIST OF CODING SYSTEMS
+## Each line corresponds to one coding system
+## Format of a line is:
+## NAME:TYPE:MNEMONIC:EOL:FLAGS:DOCSTRING,
+## where
+## TYPE = nil (no conversion), t (auto conversion),
+## 0 (Mule internal), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL)
+## EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection)
+## FLAGS =
+## if TYPE = 2 then
+## comma (`,') separated data of the followings:
+## G0, G1, G2, G3, SHORT-FORM, ASCII-EOL, ASCII-CNTL, SEVEN,
+## LOCKING-SHIFT, SINGLE-SHIFT, USE-ROMAN, USE-OLDJIS, NO-ISO6429
+## else if TYPE = 4 then
+## comma (`,') separated CCL programs for read and write
+## else
+## 0
+##
+")
+ (let ((codings (make-vector 7 nil)))
+ (mapatoms
+ (function
+ (lambda (arg)
+ (if (and arg
+ (coding-system-p arg)
+ (null (get arg 'pre-write-conversion))
+ (null (get arg 'post-read-conversion)))
+ (let* ((type (coding-system-type arg))
+ (idx (if (null type) 0 (if (eq type t) 1 (+ type 2)))))
+ (if (or (= idx 0)
+ (vectorp (coding-system-eoltype arg)))
+ (aset codings idx (cons arg (aref codings idx)))))))))
+ (let ((idx 0) elt)
+ (while (< idx 7)
+ (setq elt (aref codings idx))
+ (while elt
+ (print-coding-system (car elt))
+ (setq elt (cdr elt)))
+ (setq idx (1+ idx)))))
+ (princ "\
+############################
+## LIST OF CODING CATEGORIES (ordered by priority)
+## CATEGORY:CODING-SYSTEM
+##
+")
+ (let ((l coding-category-list))
+ (while l
+ (princ (format "%s:%s\n" (car l) (symbol-value (car l))))
+ (setq l (cdr l))))
+ ))
+\f
+;;; FONT
+
+;; Print information of a font in FONTINFO.
+(defun describe-font-internal (font-info &optional verbose)
+ (print-list "name (opened by):" (aref font-info 0))
+ (print-list " full name:" (aref font-info 1))
+ (let ((charset (aref font-info 2)))
+ (print-list " charset:"
+ (format "%s (%s)" charset (charset-description charset))))
+ (print-list " size:" (format "%d" (aref font-info 3)))
+ (print-list " height:" (format "%d" (aref font-info 4)))
+ (print-list " baseline-offset:" (format "%d" (aref font-info 5)))
+ (print-list "relative-compose:" (format "%d" (aref font-info 6))))
+
+;;;###autoload
+(defun describe-font (fontname)
+ "Display information about fonts which partially match FONTNAME."
+ (interactive "sFontname: ")
+ (or window-system
+ (error "No window system being used"))
+ (let ((font-info (font-info fontname)))
+ (if (null font-info)
+ (message "No matching font")
+ (with-output-to-temp-buffer "*Help*"
+ (describe-font-internal font-info 'verbose)))))
+
+;; Print information in FONTINFO of a fontset named FONTSET.
+(defun describe-fontset-internal (fontset fontset-info)
+ (print-list "Fontset:" fontset)
+ (let ((size (aref fontset-info 0)))
+ (print-list " size:" (format "%d" size)
+ (if (= size 0) "... which means not yet used" "")))
+ (print-list " height:" (format "%d" (aref fontset-info 1)))
+ (print-list " fonts: (charset : font name)")
+ (let* ((fonts (aref fontset-info 2))
+ elt charset requested opened)
+ (while fonts
+ (setq elt (car fonts)
+ charset (car elt)
+ requested (nth 1 elt)
+ opened (nth 2 elt))
+ (print-list " " charset ":" requested)
+ (if (stringp opened)
+ (print-list " Opened as: " opened)
+ (if (null opened) " -- open failed --"))
+ (setq fonts (cdr fonts)))))
+
+;;;###autoload
+(defun describe-fontset (fontset)
+ "Display information about FONTSET."
+ (interactive
+ (if (not window-system)
+ (error "No window system being used")
+ (let ((fontset-list (mapcar '(lambda (x) (list x)) (fontset-list))))
+ (list (completing-read "Fontset: " fontset-list)))))
+ (setq fontset (query-fontset fontset))
+ (if (null fontset)
+ (error "No matching fontset")
+ (let ((fontset-info (fontset-info fontset)))
+ (with-output-to-temp-buffer "*Help*"
+ (describe-fontset-internal fontset fontset-info)))))
+
+\f
+;;; DIAGNOSIS
+
+(defun insert-list (args)
+ (while (cdr args)
+ (insert (or (car args) "nil") " ")
+ (setq args (cdr args)))
+ (if args (insert (or (car args) "nil")))
+ (insert "\n"))
+
+(defun insert-section (sec title)
+ (insert "########################################\n"
+ "# Section " (format "%d" sec) ". " title "\n"
+ "########################################\n\n"))
+
+;;;###autoload
+(defun mule-diag ()
+ "Show diagnosis of the running Mule."
+ (interactive)
+ (let ((buf (get-buffer-create "*Diagnosis*")))
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer)
+ (insert "\t###############################\n"
+ "\t### Diagnosis of your Emacs ###\n"
+ "\t###############################\n\n"
+ "CONTENTS: Section 1. General Information\n"
+ " Section 2. Display\n"
+ " Section 3. Input methods\n"
+ " Section 4. Coding systems\n"
+ " Section 5. Charsets\n")
+ (if window-system
+ (insert " Section 6. Fontset list\n"))
+ (insert "\n")
+
+ (insert-section 1 "General Information")
+ (insert "Version of this emacs:\n " (emacs-version) "\n"
+ "Primary language:\n " primary-language "\n\n")
+
+ (insert-section 2 "Display")
+ (if window-system
+ (insert "Window-system: "
+ (symbol-name window-system)
+ (format "%s" window-system-version))
+ (insert "Terminal: " (getenv "TERM")))
+ (insert "\n\n")
+
+ (if (eq window-system 'x)
+ (let ((font (cdr (assq 'font (frame-parameters)))))
+ (insert "The selected frame is using the "
+ (if (query-fontset font) "fontset" "font")
+ ":\n\t" font))
+ (insert "Coding system of the terminal: "
+ (symbol-name (terminal-coding-system))))
+ (insert "\n\n")
+
+ (insert-section 3 "Input methods")
+ (insert "language\tinput-method\n"
+ "--------\t------------\n")
+ (let ((alist language-info-alist))
+ (while alist
+ (insert (car (car alist)))
+ (indent-to 16)
+ (let ((methods (get-language-info (car (car alist)) 'input-method)))
+ (if methods
+ (insert-list (mapcar 'car methods))
+ (insert "none\n")))
+ (setq alist (cdr alist))))
+ (insert "\n")
+ (if default-input-method
+ (insert "The input method used last time is: "
+ (cdr default-input-method)
+ "\n"
+ " for inputting the language: "
+ (car default-input-method)
+ "\n")
+ (insert "No input method has ever been selected.\n"))
+
+ (insert "\n")
+
+ (insert-section 4 "Coding systems")
+ (save-excursion (list-coding-systems))
+ (insert-buffer "*Help*")
+ (goto-char (point-max))
+ (insert "\n")
+
+ (insert-section 5 "Charsets")
+ (save-excursion (list-character-sets))
+ (insert-buffer "*Help*")
+ (goto-char (point-max))
+ (insert "\n")
+
+ (if window-system
+ (let ((fontsets (fontset-list)))
+ (insert-section 6 "Fontset list")
+ (while fontsets
+ (describe-fontset (car fontsets))
+ (insert-buffer "*Help*")
+ (setq fontsets (cdr fontsets)))))
+
+ (set-buffer-modified-p nil)
+ )
+ (let ((win (display-buffer buf)))
+ (set-window-point win 1)
+ (set-window-start win 1))
+ ))
+
+\f
+;;; DUMP DATA FILE
+
+;;;###autoload
+(defun dump-charsets ()
+ "Dump information of all charsets into the file \"charsets.dat\"."
+ (list-character-sets)
+ (set-buffer (get-buffer "*Help*"))
+ (let (make-backup-files)
+ (write-region (point-min) (point-max) "charsets.dat"))
+ (kill-emacs))
+
+;;;###autoload
+(defun dump-codings ()
+ "Dump information of all coding systems into the file \"codings.dat\"."
+ (list-coding-systems)
+ (set-buffer (get-buffer "*Help*"))
+ (let (make-backup-files)
+ (write-region (point-min) (point-max) "codings.dat"))
+ (kill-emacs))
+
--- /dev/null
+;;; mule-util.el --- Utility functions for mulitilingual environment (mule)
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: mule, multilingual
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Code:
+
+;;; String manipulations while paying attention to multibyte
+;;; characters.
+
+;;;###autoload
+(defun string-to-sequence (string type)
+ "Convert STRING to a sequence of TYPE which contains characters in STRING.
+TYPE should be `list' or `vector'.
+Multibyte characters are conserned."
+ (or (eq type 'list) (eq type 'vector)
+ (error "Invalid type: %s" type))
+ (let* ((len (length string))
+ (i 0)
+ l ch)
+ (while (< i len)
+ (setq ch (sref string i))
+ (setq l (cons ch l))
+ (setq i (+ i (char-bytes ch))))
+ (setq l (nreverse l))
+ (if (eq type 'list)
+ l
+ (vconcat l))))
+
+;;;###autoload
+(defsubst string-to-list (string)
+ "Return a list of characters in STRING."
+ (string-to-sequence string 'list))
+
+;;;###autoload
+(defsubst string-to-vector (string)
+ "Return a vector of characters in STRING."
+ (string-to-sequence string 'vector))
+
+;;;###autoload
+(defun store-substring (string idx obj)
+ "Embed OBJ (string or character) at index IDX of STRING."
+ (let* ((str (cond ((stringp obj) obj)
+ ((integerp obj) (char-to-string obj))
+ (t (error
+ "Invalid argument (should be string or character): %s"
+ obj))))
+ (string-len (length string))
+ (len (length str))
+ (i 0))
+ (while (and (< i len) (< idx string-len))
+ (aset string idx (aref str i))
+ (setq idx (1+ idx) i (1+ i)))
+ string))
+
+;;;###autoload
+(defun truncate-string-to-width (str width &optional start-column padding)
+ "Truncate string STR to fit in WIDTH columns.
+Optional 1st arg START-COLUMN if non-nil specifies the starting column.
+Optional 2nd arg PADDING if non-nil, space characters are padded at
+the head and tail of the resulting string to fit in WIDTH if necessary.
+If PADDING is nil, the resulting string may be narrower than WIDTH."
+ (or start-column
+ (setq start-column 0))
+ (let ((len (length str))
+ (idx 0)
+ (column 0)
+ (head-padding "") (tail-padding "")
+ ch last-column last-idx from-idx)
+ (condition-case nil
+ (while (< column start-column)
+ (setq ch (sref str idx)
+ column (+ column (char-width ch))
+ idx (+ idx (char-bytes ch))))
+ (args-out-of-range (setq idx len)))
+ (if (< column start-column)
+ (if padding (make-string width ?\ ) "")
+ (if (and padding (> column start-column))
+ (setq head-padding (make-string (- column start-column) ?\ )))
+ (setq from-idx idx)
+ (condition-case nil
+ (while (< column width)
+ (setq last-column column
+ last-idx idx
+ ch (sref str idx)
+ column (+ column (char-width ch))
+ idx (+ idx (char-bytes ch))))
+ (args-out-of-range (setq idx len)))
+ (if (> column width)
+ (setq column last-column idx last-idx))
+ (if (and padding (< column width))
+ (setq tail-padding (make-string (- width column) ?\ )))
+ (setq str (substring str from-idx idx))
+ (if padding
+ (concat head-padding str tail-padding)
+ str))))
+
+;;; For backward compatiblity ...
+;;;###autoload
+(defalias 'truncate-string 'truncate-string-to-width)
+(make-obsolete 'truncate-string 'truncate-string-to-width)
+\f
+;;; Nested alist handler. Nested alist is alist whose elements are
+;;; also nested alist.
+
+;;;###autoload
+(defsubst nested-alist-p (obj)
+ "Return t if OBJ is a nesetd alist.
+
+Nested alist is a list of the form (ENTRY . BRANCHES), where ENTRY is
+any Lisp object, and BRANCHES is a list of cons cells of the form
+(KEY-ELEMENT . NESTED-ALIST).
+
+You can use a nested alist to store any Lisp object (ENTRY) for a key
+sequence KEYSEQ, where KEYSEQ is a sequence of KEY-ELEMENT. KEYSEQ
+can be a string, a vector, or a list."
+ (and obj (listp obj) (listp (cdr obj))))
+
+;;;###autoload
+(defun set-nested-alist (keyseq entry alist &optional len branches)
+ "Set ENTRY for KEYSEQ in a nested alist ALIST.
+Optional 4th arg LEN non-nil means the firlst LEN elements in KEYSEQ
+ is considered.
+Optional argument BRANCHES if non-nil is branches for a keyseq
+longer than KEYSEQ.
+See the documentation of `nested-alist-p' for more detail."
+ (or (nested-alist-p alist)
+ (error "Invalid arguement %s" alist))
+ (let ((islist (listp keyseq))
+ (len (or len (length keyseq)))
+ (i 0)
+ key-elt slot)
+ (while (< i len)
+ (if (null (nested-alist-p alist))
+ (error "Keyseq %s is too long for this nested alist" keyseq))
+ (setq key-elt (if islist (nth i keyseq) (aref keyseq i)))
+ (setq slot (assoc key-elt (cdr alist)))
+ (if (null slot)
+ (progn
+ (setq slot (cons key-elt (list t)))
+ (setcdr alist (cons slot (cdr alist)))))
+ (setq alist (cdr slot))
+ (setq i (1+ i)))
+ (setcar alist entry)
+ (if branches
+ (if (cdr alist)
+ (error "Can't set branches for keyseq %s" keyseq)
+ (setcdr alist branches)))))
+
+;;;###autoload
+(defun lookup-nested-alist (keyseq alist &optional len start nil-for-too-long)
+ "Look up key sequence KEYSEQ in nested alist ALIST. Return the definition.
+Optional 1st argument LEN specifies the length of KEYSEQ.
+Optional 2nd argument START specifies index of the starting key.
+The returned value is normally a nested alist of which
+car part is the entry for KEYSEQ.
+If ALIST is not deep enough for KEYSEQ, return number which is
+ how many key elements at the front of KEYSEQ it takes
+ to reach a leaf in ALIST.
+Optional 3rd argument NIL-FOR-TOO-LONG non-nil means return nil
+ even if ALIST is not deep enough."
+ (or (nested-alist-p alist)
+ (error "invalid arguement %s" alist))
+ (or len
+ (setq len (length keyseq)))
+ (let ((i (or start 0)))
+ (if (catch 'lookup-nested-alist-tag
+ (if (listp keyseq)
+ (while (< i len)
+ (if (setq alist (cdr (assoc (nth i keyseq) (cdr alist))))
+ (setq i (1+ i))
+ (throw 'lookup-nested-alist-tag t))))
+ (while (< i len)
+ (if (setq alist (cdr (assoc (aref keyseq i) (cdr alist))))
+ (setq i (1+ i))
+ (throw 'lookup-nested-alist-tag t))))
+ ;; KEYSEQ is too long.
+ (if nil-for-too-long nil i)
+ alist)))
+
+;; Coding system related functions.
+
+;;;###autoload
+(defun set-coding-system-alist (target-type regexp coding-system
+ &optional operation)
+ "Update `coding-system-alist' according to the arguments.
+TARGET-TYPE specifies a type of the target: `file', `process', or `network'.
+ TARGET-TYPE tells which slots of coding-system-alist should be affected.
+ If `file', it affects slots for insert-file-contents and write-region.
+ If `process', it affects slots for call-process, call-process-region, and
+ start-process.
+ If `network', it affects a slot for open-network-process.
+REGEXP is a regular expression matching a target of I/O operation.
+CODING-SYSTEM is a coding system to perform code conversion
+ on the I/O operation, or a cons of coding systems for decoding and
+ encoding respectively, or a function symbol which returns the cons.
+Optional arg OPERATION if non-nil specifies directly one of slots above.
+ The valid value is: insert-file-contents, write-region,
+ call-process, call-process-region, start-process, or open-network-stream.
+If OPERATION is specified, TARGET-TYPE is ignored.
+See the documentation of `coding-system-alist' for more detail."
+ (or (stringp regexp)
+ (error "Invalid regular expression: %s" regexp))
+ (or (memq target-type '(file process network))
+ (error "Invalid target type: %s" target-type))
+ (if (symbolp coding-system)
+ (if (not (fboundp coding-system))
+ (progn
+ (check-coding-system coding-system)
+ (setq coding-system (cons coding-system coding-system))))
+ (check-coding-system (car coding-system))
+ (check-coding-system (cdr coding-system)))
+ (let ((op-list (if operation (list operation)
+ (cond ((eq target-type 'file)
+ '(insert-file-contents write-region))
+ ((eq target-type 'process)
+ '(call-process call-process-region start-process))
+ (t ; i.e. (eq target-type network)
+ '(open-network-stream)))))
+ slot)
+ (while op-list
+ (setq slot (assq (car op-list) coding-system-alist))
+ (if slot
+ (let ((chain (cdr slot)))
+ (if (catch 'tag
+ (while chain
+ (if (string= regexp (car (car chain)))
+ (progn
+ (setcdr (car chain) coding-system)
+ (throw 'tag nil)))
+ (setq chain (cdr chain)))
+ t)
+ (setcdr slot (cons (cons regexp coding-system) (cdr slot)))))
+ (setq coding-system-alist
+ (cons (cons (car op-list) (list (cons regexp coding-system)))
+ coding-system-alist)))
+ (setq op-list (cdr op-list)))))
+
+;;;###autoload
+(defun coding-system-list ()
+ "Return a list of all existing coding systems."
+ (let (l)
+ (mapatoms (lambda (x) (if (get x 'coding-system) (setq l (cons x l)))))
+ l))
+
+\f
+;;; Composite charcater manipulations.
+
+;;;###autoload
+(defun compose-region (start end)
+ "Compose all characters in the current region into one composite character.
+When called from a program, expects two arguments,
+positions (integers or markers) specifying the region."
+ (interactive "r")
+ (save-excursion
+ (let ((str (buffer-substring start end)))
+ (goto-char start)
+ (delete-region start end)
+ (insert (compose-string str)))))
+
+;;;###autoload
+(defun decompose-region (start end)
+ "Decompose all composite characters in the current region.
+Composite characters are broken up into individual components.
+When called from a program, expects two arguments,
+positions (integers or markers) specifying the region."
+ (interactive "r")
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ (let ((enable-multibyte-characters nil)
+ ;; This matches the whole bytes of single composite character.
+ (re-cmpchar "\200[\240-\377]+")
+ p ch str)
+ (while (re-search-forward re-cmpchar nil t)
+ (setq str (buffer-substring (match-beginning 0) (match-end 0)))
+ (delete-region (match-beginning 0) (match-end 0))
+ (insert (decompose-composite-char (string-to-char str)))))))
+
+;;;###autoload
+(defconst reference-point-alist
+ '((tl . 0) (tc . 1) (tr . 2)
+ (ml . 3) (mc . 4) (mr . 5)
+ (bl . 6) (bc . 7) (br . 8)
+ (top-left . 0) (top-center . 1) (top-right . 2)
+ (mid-left . 3) (mid-center . 4) (mid-right . 5)
+ (bottom-left . 6) (bottom-center . 7) (bottom-right . 8)
+ (0 . 0) (1 . 1) (2 . 2)
+ (3 . 3) (4 . 4) (5 . 5)
+ (6 . 6) (7 . 7) (8 . 8))
+ "Alist of reference point symbols vs reference point codes.
+Meanings of reference point codes are as follows:
+
+ 0----1----2 <-- ascent 0:tl or top-left
+ | | 1:tc or top-center
+ | | 2:tr or top-right
+ | | 3:ml or mid-left
+ | 4 <--+---- center 4:mc or mid-center
+ | | 5:mr or mid-right
+--- 3 5 <-- baseline 6:bl or bottom-left
+ | | 7:bc or bottom-center
+ 6----7----8 <-- descent 8:br or bottom-right
+
+Reference point symbols are to be used to specify composition rule of
+the form \(GLOBAL-REF-POINT . NEW-REF-POINT), where GLOBAL-REF-POINT
+is a reference point in the overall glyphs already composed, and
+NEW-REF-POINT is a reference point in the new glyph to be added.
+
+For instance, if GLOBAL-REF-POINT is 8 and NEW-REF-POINT is 1, the
+overall glyph is updated as follows:
+
+ +-------+--+ <--- new ascent
+ | | |
+ | global| |
+ | glyph | |
+--- | | | <--- baseline (doesn't change)
+ +----+--+--+
+ | | new |
+ | |glyph|
+ +----+-----+ <--- new descent
+")
+
+;; Return a string for char CH to be embedded in multibyte form of
+;; composite character.
+(defun compose-chars-component (ch)
+ (if (< ch 128)
+ (format "\240%c" (+ ch 128))
+ (let ((str (char-to-string ch)))
+ (if (cmpcharp ch)
+ (if (/= (aref str 1) ?\xFF)
+ (error "Char %c can't be composed" ch)
+ (substring str 2))
+ (aset str 0 (+ (aref str 0) ?\x20))
+ str))))
+
+;; Return a string for composition rule RULE to be embedded in
+;; multibyte form of composite character.
+(defsubst compose-chars-rule (rule)
+ (char-to-string (+ ?\xA0
+ (* (cdr (assq (car rule) reference-point-alist)) 9)
+ (cdr (assq (cdr rule) reference-point-alist)))))
+
+;;;###autoload
+(defun compose-chars (first-component &rest args)
+ "Return one char string composed from the arguments.
+Each argument is a character (including a composite chararacter)
+or a composition rule.
+A composition rule has the form \(GLOBAL-REF-POINT . NEW-REF-POINT).
+See the documentation of `reference-point-alist' for more detail."
+ (if (= (length args) 0)
+ (char-to-string first-component)
+ (let* ((with-rule (consp (car args)))
+ (str (if with-rule (concat (vector leading-code-composition ?\xFF))
+ (char-to-string leading-code-composition))))
+ (setq str (concat str (compose-chars-component first-component)))
+ (while args
+ (if with-rule
+ (progn
+ (if (not (consp (car args)))
+ (error "Invalid composition rule: %s" (car args)))
+ (setq str (concat str (compose-chars-rule (car args))
+ (compose-chars-component (car (cdr args))))
+ args (cdr (cdr args))))
+ (setq str (concat str (compose-chars-component (car args)))
+ args (cdr args))))
+ str)))
+
+;;;###autoload
+(defun decompose-composite-char (char &optional type with-composition-rule)
+ "Convert composite character CHAR to a string containing components of CHAR.
+Optional 1st arg TYPE specifies the type of sequence returned.
+It should be `string' (default), `list', or `vector'.
+Optional 2nd arg WITH-COMPOSITION-RULE non-nil means the returned
+sequence contains embedded composition rules if any. In this case, the
+order of elements in the sequence is the same as arguments for
+`compose-chars' to create CHAR.
+If TYPE is omitted or is `string', composition rules are omitted
+even if WITH-COMPOSITION-RULE is t."
+ (or type
+ (setq type 'string))
+ (let* ((len (composite-char-component-count char))
+ (i (1- len))
+ l)
+ (setq with-composition-rule (and with-composition-rule
+ (not (eq type 'string))
+ (composite-char-composition-rule-p char)))
+ (while (> i 0)
+ (setq l (cons (composite-char-component char i) l))
+ (if with-composition-rule
+ (let ((rule (- (composite-char-composition-rule char i) ?\xA0)))
+ (setq l (cons (cons (/ rule 9) (% rule 9)) l))))
+ (setq i (1- i)))
+ (setq l (cons (composite-char-component char 0) l))
+ (cond ((eq type 'string)
+ (apply 'concat-chars l))
+ ((eq type 'list)
+ l)
+ (t ; i.e. TYPE is vector
+ (vconcat l)))))
+
+;;; mule-util.el ends here
--- /dev/null
+;;; mule.el --- basic commands for mulitilingual environment
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: mule, multilingual, character set, coding system
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Code:
+
+(defconst mule-version "3.0 (MOMIJINOGA)" "\
+Version number and name of this version of MULE (multilingual environment).")
+
+(defconst mule-version-date "1998.1.1" "\
+Distribution date of this version of MULE (multilingual environment).")
+
+(defun load-with-code-conversion (fullname file &optional noerror nomessage)
+ "Execute a file of Lisp code named FILE whose absolute path is FULLNAME.
+The FILE is decoded before evaluation if necessary.
+If optional second arg NOERROR is non-nil,
+ report no error if FILE doesn't exist.
+Print messages at start and end of loading unless
+ optional third arg NOMESSAGE is non-nil.
+Return t if file exists."
+ (if (null (file-readable-p fullname))
+ (and (null noerror)
+ (signal 'file-error (list "Cannot open load file" file)))
+ ;; Read file with code conversion, and then eval.
+ (let* ((buffer
+ ;; To avoid any autoloading, set default-major-mode to
+ ;; fundamental-mode.
+ (let ((default-major-mode 'fundamental-mode))
+ ;; We can't use `generate-new-buffer' because files.el
+ ;; is not yet loaded.
+ (get-buffer-create (generate-new-buffer-name " *load*"))))
+ (load-in-progress t))
+ (or nomessage (message "Loading %s..." file))
+ (unwind-protect
+ (progn
+ (save-excursion
+ (set-buffer buffer)
+ (insert-file-contents fullname)
+ ;; We must set `buffer-file-name' for `eval-buffer' and
+ ;; `load-history'.
+ (setq buffer-file-name file)
+ ;; Make `kill-buffer' quiet.
+ (set-buffer-modified-p nil))
+ ;; Eval in the original buffer.
+ (eval-buffer buffer))
+ (kill-buffer buffer))
+ (let ((hook (assoc file after-load-alist)))
+ (if hook
+ (mapcar (function eval) (cdr hook))))
+ (or nomessage noninteractive
+ (message "Loading %s...done" file))
+ t)))
+
+;; API (Application Program Interface) for charsets.
+
+;; Return t if OBJ is a quoted symbol.
+(defsubst quoted-symbol-p (obj)
+ (and (listp obj) (eq (car obj) 'quote)))
+
+(defsubst charsetp (object)
+ "T is OBJECT is a charset."
+ (and (symbolp object) (vectorp (get object 'charset))))
+
+(defsubst charset-info (charset)
+ "Return a vector of information of CHARSET.
+The elements of the vector are:
+ CHARSET-ID, BYTES, DIMENSION, CHARS, WIDTH, DIRECTION,
+ LEADING-CODE-BASE, LEADING-CODE-EXT,
+ ISO-FINAL-CHAR, ISO-GRAPHIC-PLANE,
+ REVERSE-CHARSET, SHORT-NAME, LONG-NAME, DESCRIPTION,
+ PLIST,
+where
+CHARSET-ID (integer) is the identification number of the charset.
+DIMENSION (integer) is the number of bytes to represent a character of
+the charset: 1 or 2.
+CHARS (integer) is the number of characters in a dimension: 94 or 96.
+BYTE (integer) is the length of multi-byte form of a character in
+ the charset: one of 1, 2, 3, and 4.
+WIDTH (integer) is the number of columns a character in the charset
+ occupies on the screen: one of 0, 1, and 2.
+DIRECTION (integer) is the rendering direction of characters in the
+ charset when rendering. If 0, render from right to left, else
+ render from left to right.
+LEADING-CODE-BASE (integer) is the base leading-code for the
+ charset.
+LEADING-CODE-EXT (integer) is the extended leading-code for the
+ charset. All charsets of less than 0xA0 has the value 0.
+ISO-FINAL-CHAR (character) is the final character of the
+ corresponding ISO 2022 charset.
+ISO-GRAPHIC-PLANE (integer) is the graphic plane to be invoked
+ while encoding to variants of ISO 2022 coding system, one of the
+ following: 0/graphic-plane-left(GL), 1/graphic-plane-right(GR).
+REVERSE-CHARSET (integer) is the charset which differs only in
+ LEFT-TO-RIGHT value from the charset. If there's no such a
+ charset, the value is -1.
+SHORT-NAME (string) is the short name to refer to the charset.
+LONG-NAME (string) is the long name to refer to the charset
+DESCRIPTION (string) is the description string of the charset.
+PLIST (property list) may contain any type of information a user
+ want to put and get by functions `put-charset-property' and
+ `get-charset-property' respectively."
+ (get charset 'charset))
+
+(defmacro charset-id (charset)
+ "Return charset identification number of CHARSET."
+ (if (and (listp charset) (eq (car charset) 'quote))
+ (aref (charset-info (nth 1 charset)) 0)
+ `(aref (charset-info ,charset) 0)))
+
+(defmacro charset-bytes (charset)
+ (if (quoted-symbol-p charset)
+ (aref (charset-info (nth 1 charset)) 1)
+ `(aref (charset-info ,charset) 1)))
+
+(defmacro charset-dimension (charset)
+ (if (quoted-symbol-p charset)
+ (aref (charset-info (nth 1 charset)) 2)
+ `(aref (charset-info ,charset) 2)))
+
+(defmacro charset-chars (charset)
+ (if (quoted-symbol-p charset)
+ (aref (charset-info (nth 1 charset)) 3)
+ `(aref (charset-info ,charset) 3)))
+
+(defmacro charset-width (charset)
+ (if (quoted-symbol-p charset)
+ (aref (charset-info (nth 1 charset)) 4)
+ `(aref (charset-info ,charset) 4)))
+
+(defmacro charset-direction (charset)
+ (if (quoted-symbol-p charset)
+ (aref (charset-info (nth 1 charset)) 5)
+ `(aref (charset-info ,charset) 5)))
+
+(defmacro charset-iso-final-char (charset)
+ (if (quoted-symbol-p charset)
+ (aref (charset-info (nth 1 charset)) 8)
+ `(aref (charset-info ,charset) 8)))
+
+(defmacro charset-iso-graphic-plane (charset)
+ (if (quoted-symbol-p charset)
+ (aref (charset-info (nth 1 charset)) 9)
+ `(aref (charset-info ,charset) 9)))
+
+(defmacro charset-reverse-charset (charset)
+ (if (quoted-symbol-p charset)
+ (aref (charset-info (nth 1 charset)) 10)
+ `(aref (charset-info ,charset) 10)))
+
+(defmacro charset-short-name (charset)
+ (if (quoted-symbol-p charset)
+ (aref (charset-info (nth 1 charset)) 11)
+ `(aref (charset-info ,charset) 11)))
+
+(defmacro charset-long-name (charset)
+ (if (quoted-symbol-p charset)
+ (aref (charset-info (nth 1 charset)) 12)
+ `(aref (charset-info ,charset) 12)))
+
+(defmacro charset-description (charset)
+ (if (quoted-symbol-p charset)
+ (aref (charset-info (nth 1 charset)) 13)
+ `(aref (charset-info ,charset) 13)))
+
+(defmacro charset-plist (charset)
+ (if (quoted-symbol-p charset)
+ (aref (charset-info (nth 1 charset)) 14)
+ `(aref (charset-info ,charset) 14)))
+
+(defun set-charset-plist (charset plist)
+ (aset (charset-info charset) 14 plist))
+
+(defmacro make-char (charset &optional c1 c2)
+ (if (quoted-symbol-p charset)
+ `(make-char-internal ,(charset-id (nth 1 charset)) ,c1 ,c2)
+ `(make-char-internal (charset-id ,charset) ,c1 ,c2)))
+
+;; Coding-system staffs
+
+;; Coding-system object is a symbol that has the property
+;; `coding-system' and `eol-type'.
+;;
+;; The value of the property `coding-system' is a coding-vector of the
+;; format: [TYPE MNEMONIC DOCSTRING NOT-USED-NOW FLAGS].
+;; See comments in src/coding.c for more detail. The property value
+;; may be another coding-system, in which case, the coding-vector
+;; should be taken from that coding-system.
+;;
+;; The value of the property `eol-type' is integer 0..2 or a vector of
+;; length 3. The integer value 0, 1, and 2 indicate the format of
+;; end-of-line LF, CRLF, and CR respectively. The vector value
+;; indicates that the format of end-of-line should be detected
+;; automatically. Nth element of the vector is the subsidiary
+;; coding-system whose `eol-type' property is integer value.
+;;
+;; Coding-system may also have properties `post-read-conversion' and
+;; `pre-write-conversion and the values are functions.
+;;
+;; The function in `post-read-conversion' is called after some text is
+;; inserted and decoded along the coding-system and before any
+;; functions in `after-insert-functions' are called. The arguments to
+;; this function is the same as those of a function in
+;; `after-insert-functions', i.e. LENGTH of a text while putting point
+;; at the head of the text to be decoded
+;;
+;; The function in `pre-write-conversion' is called after all
+;; functions in `write-region-annotate-functions' and
+;; `buffer-file-format' are called, and before the text is encoded by
+;; the coding-system. The arguments to this function is the same as
+;; those of a function in `write-region-annotate-functions', i.e. FROM
+;; and TO specifying region of a text.
+
+(defsubst coding-vector-type (vec) (aref vec 0))
+(defsubst coding-vector-mnemonic (vec) (aref vec 1))
+(defsubst coding-vector-docstring (vec) (aref vec 2))
+(defsubst coding-vector-flags (vec) (aref vec 4))
+
+;; Return type of CODING-SYSTEM.
+(defun coding-system-type (coding-system)
+ (let ((vec (coding-system-vector coding-system)))
+ (if vec (coding-vector-type vec))))
+
+;; Return mnemonic character of CODING-SYSTEM.
+(defun coding-system-mnemonic (coding-system)
+ (let ((vec (coding-system-vector coding-system)))
+ (if vec (coding-vector-mnemonic vec)
+ ?-)))
+
+;; Return docstring of CODING-SYSTEM.
+(defun coding-system-docstring (coding-system)
+ (let ((vec (coding-system-vector coding-system)))
+ (if vec (coding-vector-docstring vec))))
+
+;; Return flags of CODING-SYSTEM.
+(defun coding-system-flags (coding-system)
+ (let ((vec (coding-system-vector coding-system)))
+ (if vec (coding-vector-flags vec))))
+
+;; Return eol-type of CODING-SYSTEM.
+(defun coding-system-eoltype (coding-system)
+ (and coding-system
+ (or (get coding-system 'eol-type)
+ (coding-system-eoltype (get coding-system 'coding-system)))))
+
+;; Return mnemonic character of eol-type of CODING-SYSTEM.
+(defun coding-system-eoltype-mnemonic (coding-system)
+ (let ((eol-type (coding-system-eoltype coding-system)))
+ (cond ((vectorp eol-type) eol-mnemonic-undecided)
+ ((eq eol-type 0) eol-mnemonic-unix)
+ ((eq eol-type 1) eol-mnemonic-unix)
+ ((eq eol-type 2) eol-mnemonic-unix)
+ (t ?-))))
+
+;; Return function for post-read-conversion of CODING-SYSTEM.
+(defun coding-system-post-read-conversion (coding-system)
+ (and coding-system
+ (symbolp coding-system)
+ (or (get coding-system 'post-read-conversion)
+ (coding-system-post-read-conversion
+ (get coding-system 'coding-system)))))
+
+;; Return function for pre-write-conversion of CODING-SYSTEM.
+(defun coding-system-pre-write-conversion (coding-system)
+ (and coding-system
+ (symbolp coding-system)
+ (or (get coding-system 'pre-write-conversion)
+ (coding-system-pre-write-conversion
+ (get coding-system 'coding-system)))))
+
+(defun make-coding-system (coding-system type mnemonic docstring
+ &optional flags)
+ "Define a new CODING-SYSTEM (symbol).
+Remaining arguments are TYPE, MNEMONIC, DOCSTRING, and FLAGS (optional).
+TYPE is an integer value indicating the type of coding-system as follows:
+ 0: Emacs internal format,
+ 1: Shift-JIS (or MS-Kanji) used mainly on Japanese PC,
+ 2: ISO-2022 including many variants,
+ 3: Big5 used mainly on Chinese PC,
+ 4: private, CCL programs provide encoding/decoding algorithm.
+MNEMONIC is a character to be displayed on mode line for the coding-system.
+DOCSTRING is a documentation string for the coding-system.
+FLAGS specifies more precise information of each TYPE.
+ If TYPE is 2 (ISO-2022), FLAGS should be a list of:
+ CHARSET0, CHARSET1, CHARSET2, CHARSET3, SHORT-FORM,
+ ASCII-EOL, ASCII-CNTL, SEVEN, LOCKING-SHIFT, SINGLE-SHIFT,
+ USE-ROMAN, USE-OLDJIS, NO-ISO6429.
+ CHARSETn are character sets initially designated to Gn graphic registers.
+ If CHARSETn is nil, Gn is never used.
+ If CHARSETn is t, Gn can be used but nothing designated initially.
+ If CHARSETn is a list of character sets, those character sets are
+ designated to Gn on output, but nothing designated to Gn initially.
+ SHORT-FORM non-nil means use short designation sequence on output.
+ ASCII-EOL non-nil means designate ASCII to g0 at end of line on output.
+ ASCII-CNTL non-nil means designate ASCII to g0 before control codes and
+ SPACE on output.
+ SEVEN non-nil means use 7-bit code only on output.
+ LOCKING-SHIFT non-nil means use locking-shift.
+ SINGLE-SHIFT non-nil means use single-shift.
+ USE-ROMAN non-nil means designate JIS0201-1976-Roman instead of ASCII.
+ USE-OLDJIS non-nil means designate JIS0208-1976 instead of JIS0208-1983.
+ NO-ISO6429 non-nil means not use ISO6429's direction specification.
+ If TYPE is 4 (private), FLAGS should be a cons of CCL programs,
+ for encoding and decoding. See the documentation of CCL for more detail."
+
+ ;; At first, set a value of `coding-system' property.
+ (let ((coding-vector (make-vector 5 nil)))
+ (aset coding-vector 0 type)
+ (aset coding-vector 1
+ ;; MNEMONIC must be a printable character.
+ (if (and (> mnemonic ? ) (< mnemonic 127)) mnemonic ? ))
+ (aset coding-vector 2 (if (stringp docstring) docstring ""))
+ (aset coding-vector 3 nil) ; obsolete element
+ (cond ((eq type 2) ; ISO2022
+ (let ((i 0)
+ (vec (make-vector 32 nil)))
+ (while (< i 4)
+ (let ((charset (car flags)))
+ (if (and charset (not (eq charset t)))
+ (if (symbolp charset)
+ (setq charset (charset-id charset))
+ (let (elt l)
+ (while charset
+ (setq elt (car charset))
+ (if (and elt (not (eq elt t)))
+ (setq elt (charset-id elt)))
+ (setq l (cons elt l))
+ (setq charset (cdr charset)))
+ (setq charset (nreverse l)))))
+ (aset vec i charset))
+ (setq flags (cdr flags) i (1+ i)))
+ (while (and (< i 32) flags)
+ (aset vec i (car flags))
+ (setq flags (cdr flags) i (1+ i)))
+ (aset coding-vector 4 vec)))
+ ((eq type 4) ; private
+ (if (and (consp flags)
+ (vectorp (car flags))
+ (vectorp (cdr flags)))
+ (aset coding-vector 4 flags)
+ (error "Invalid FLAGS argument for TYPE 4 (CCL)")))
+ (t (aset coding-vector 4 flags)))
+ (put coding-system 'coding-system coding-vector))
+
+ ;; Next, set a value of `eol-type' property. The value is a vector
+ ;; of subsidiary coding-systems, each corresponds to a coding-system
+ ;; for the detected end-of-line format.
+ (let ((codings (vector (intern (format "%s-unix" coding-system))
+ (intern (format "%s-dos" coding-system))
+ (intern (format "%s-mac" coding-system))))
+ (i 0))
+ (while (< i 3)
+ (put (aref codings i) 'coding-system coding-system)
+ (put (aref codings i) 'eol-type i)
+ (setq i (1+ i)))
+ (put coding-system 'eol-type codings))
+ )
+
+(defun define-coding-system-alias (symbol new-symbol)
+ "Define NEW-SYMBOL as the same coding system as SYMBOL."
+ (check-coding-system symbol)
+ (put new-symbol 'coding-system (get symbol 'coding-system))
+ (let ((eol-type (get symbol 'eol-type)))
+ (if (vectorp eol-type)
+ (let* ((name (symbol-name new-symbol))
+ (new (vector (intern (concat name "-unix"))
+ (intern (concat name "-dos"))
+ (intern (concat name "-mac"))))
+ (i 0))
+ (while (< i 3)
+ (define-coding-system-alias (aref eol-type i) (aref new i))
+ (setq i (1+ i)))
+ (setq eol-type new)))
+ (put new-symbol 'eol-type eol-type)))
+
+(defvar buffer-file-coding-system nil
+ "Coding-system of the file which the current-buffer is visiting.")
+(make-variable-buffer-local 'buffer-file-coding-system)
+;; This value should not be reset by changing major mode.
+(put 'buffer-file-coding-system 'permanent-local t)
+
+(defun set-buffer-file-coding-system (coding-system &optional force)
+ "Set buffer-file-coding-system of the current buffer to CODING-SYSTEM.
+If eol-type of the current buffer-file-coding-system is an integer value N, and
+ eol-type of CODING-SYSTEM is a vector, the Nth element of the vector is set
+ instead of CODING-SYSTEM itself.
+Optional prefix argument FORCE non-nil means CODING-SYSTEM is set
+ regardless of eol-type of the current buffer-file-coding-system."
+ (interactive "zBuffer-file-coding-system: \nP")
+ (check-coding-system coding-system)
+ (if (null force)
+ (let ((x (coding-system-eoltype buffer-file-coding-system))
+ (y (coding-system-eoltype coding-system)))
+ (if (and (numberp x) (>= x 0) (<= x 2) (vectorp y))
+ (setq coding-system (aref y x)))))
+ (setq buffer-file-coding-system coding-system)
+ (set-buffer-modified-p t)
+ (force-mode-line-update))
+
+(defun set-current-process-coding-system (input output)
+ (interactive
+ "zCoding-system for process input: \nzCoding-system for process output: ")
+ (let ((proc (get-buffer-process (current-buffer))))
+ (if (null proc)
+ (error "no process")
+ (check-coding-system input)
+ (check-coding-system output)
+ (set-process-coding-system proc input output)))
+ (force-mode-line-update))
+
+(defvar default-process-coding-system (cons nil nil)
+ "Cons of default values used to read from and write to process.")
+
+(defun set-coding-priority (arg)
+ "Set priority of coding-category according to LIST.
+LIST is a list of coding-categories ordered by priority."
+ (let (l)
+ ;; Put coding-categories listed in ARG to L while checking the
+ ;; validity. We assume that `coding-category-list' contains whole
+ ;; coding-categories.
+ (while arg
+ (if (null (memq (car arg) coding-category-list))
+ (error "Invalid element in argument: %s" (car arg)))
+ (setq l (cons (car arg) l))
+ (setq arg (cdr arg)))
+ ;; Put coding-category not listed in ARG to L.
+ (while coding-category-list
+ (if (null (memq (car coding-category-list) l))
+ (setq l (cons (car coding-category-list) l)))
+ (setq coding-category-list (cdr coding-category-list)))
+ ;; Update `coding-category-list' and return it.
+ (setq coding-category-list (nreverse l))))
+
+;;; FILE I/O
+
+;; Set buffer-file-coding-system of the current buffer after some text
+;; is inserted.
+(defun after-insert-file-set-buffer-file-coding-system (inserted)
+ (if last-coding-system-used
+ (let ((coding-system
+ (find-new-buffer-file-coding-system last-coding-system-used))
+ (modified-p (buffer-modified-p)))
+ (if coding-system
+ (set-buffer-file-coding-system coding-system))
+ (set-buffer-modified-p modified-p)))
+ nil)
+
+(setq after-insert-file-functions
+ (cons 'after-insert-file-set-buffer-file-coding-system
+ after-insert-file-functions))
+
+;; The coding-vector and eol-type of coding-system returned is decided
+;; independently in the following order.
+;; 1. That of buffer-file-coding-system locally bound.
+;; 2. That of CODING.
+
+(defun find-new-buffer-file-coding-system (coding)
+ "Return a coding system for a buffer when a file of CODING is inserted.
+The returned value is set to `buffer-file-coding-system' of the
+current buffer. Return nil if there's no need of setting new
+buffer-file-coding-system."
+ (let (local-coding local-eol
+ found-eol
+ new-coding new-eol)
+ (if (null coding)
+ ;; Nothing found about coding.
+ nil
+
+ ;; Get information of the current local value of
+ ;; `buffer-file-coding-system' in LOCAL-EOL and LOCAL-CODING.
+ (if (local-variable-p 'buffer-file-coding-system)
+ ;; Something already set locally.
+ (progn
+ (setq local-eol (coding-system-eoltype buffer-file-coding-system))
+ (if (null (numberp local-eol))
+ ;; But eol-type is not yet set.
+ (setq local-eol nil))
+ (if (null (eq (coding-system-type buffer-file-coding-system) t))
+ ;; This is not automatic-conversion.
+ (progn
+ (setq local-coding buffer-file-coding-system)
+ (while (symbolp (get local-coding 'coding-system))
+ (setq local-coding (get local-coding 'coding-system))))
+ )))
+
+ (if (and local-eol local-coding)
+ ;; The current buffer has already set full coding-system, we
+ ;; had better not change it.
+ nil
+
+ (setq found-eol (coding-system-eoltype coding))
+ (if (null (numberp found-eol))
+ ;; But eol-type is not found.
+ (setq found-eol nil))
+ (if (eq (coding-system-type coding) t)
+ ;; This is automatic-conversion, which means nothing found
+ ;; except for eol-type.
+ (setq coding nil))
+
+ ;; The local setting takes precedence over the found one.
+ (setq new-coding (or local-coding coding))
+ (setq new-eol (or local-eol found-eol))
+ (if (and (numberp new-eol)
+ (vectorp (coding-system-eoltype new-coding)))
+ (setq new-coding
+ (aref (coding-system-eoltype new-coding) new-eol)))
+ new-coding))))
+
+(provide 'mule)
+
+;;; mule.el ends here
--- /dev/null
+;;; quail.el -- provides simple input method for multilingual text
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Author: Kenichi HANDA <handa@etl.go.jp>
+;; Naoto TAKAHASHI <ntakahas@etl.go.jp>
+;; Maintainer: Kenichi HANDA <handa@etl.go.jp>
+;; Keywords: mule, multilingual, input method
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; In Quail minor mode, you can input multilingual text easily. By
+;; defining a translation table (named Quail map) which maps ASCII key
+;; string to multilingual character or string, you can input any text
+;; from ASCII keyboard.
+;;
+;; We use words "translation" and "conversion" differently. The
+;; former is done by Quail package itself, the latter is the further
+;; process of converting a translated text to some more desirable
+;; text. For instance, Quail package for Japanese (`quail-jp')
+;; translates Roman text (transliteration of Japanese in Latin
+;; alphabets) to Hiragana text, which is then converted to
+;; Kanji-and-Kana mixed text or Katakana text by commands specified in
+;; CONVERSION-KEYS argument of the Quail package.
+
+;;; Code:
+
+(require 'faces)
+
+;; Buffer local variables
+
+(defvar quail-current-package nil
+ "The current Quail package to input multilingual text in Quail minor mode.
+See the documentation of `quail-package-alist' for the format.")
+(make-variable-buffer-local 'quail-current-package)
+(put 'quail-current-package 'permanent-local t)
+
+;; Quail uses the following two buffers to assist users.
+;; A buffer to show available key sequence or translation list.
+(defvar quail-guidance-buf nil)
+;; A buffer to show completion list of the current key sequence.
+(defvar quail-completion-buf nil)
+
+(defvar quail-mode nil
+ "Non-nil if in Quail minor mode.")
+(make-variable-buffer-local 'quail-mode)
+(put 'quail-mode 'permanent-local t)
+
+(defvar quail-overlay nil
+ "Overlay which covers the current translation region of Quail.")
+(make-variable-buffer-local 'quail-overlay)
+
+(defvar quail-conv-overlay nil
+ "Overlay which covers the text to be converted in Quail mode.")
+(make-variable-buffer-local 'quail-conv-overlay)
+
+(defvar quail-current-key nil
+ "Current key for translation in Quail mode.")
+
+(defvar quail-current-str nil
+ "Currently selected translation of the current key.")
+
+(defvar quail-current-translations nil
+ "Cons of indices and vector of possible translations of the current key.")
+
+;; A flag to control conversion region. Normally nil, but if set to
+;; t, it means we must start the new conversion region if new key to
+;; be translated is input.
+(defvar quail-reset-conversion-region nil)
+
+;; Quail package handlers.
+
+(defvar quail-package-alist nil
+ "List of Quail packages.
+A Quail package is a list of these elements:
+ NAME, TITLE, QUAIL-MAP, GUIDANCE, DOCSTRING, TRANSLATION-KEYS,
+ FORGET-LAST-SELECTION, DETERMINISTIC, KBD-TRANSLATE, SHOW-LAYOUT,
+ DECODE-MAP, MAXIMUM-SHORTEST, OVERLAY-PLIST, UPDATE-TRANSLATION-FUNCTION,
+ CONVERSION-KEYS.
+
+QUAIL-MAP is a data structure to map key strings to translations. For
+the format, see the documentation of `quail-map-p'.
+
+DECODE-MAP is an alist of translations and corresponding keys.
+
+See the documentation of `quail-define-package' for the other elements.")
+
+;; Return various slots in the current quail-package.
+
+(defsubst quail-name ()
+ "Return the name of the current Quail package."
+ (nth 0 quail-current-package))
+(defsubst quail-title ()
+ "Return the title of the current Quail package."
+ (nth 1 quail-current-package))
+(defsubst quail-map ()
+ "Return the translation map of the current Quail package."
+ (nth 2 quail-current-package))
+(defsubst quail-guidance ()
+ "Return an object used for `guidance' feature of the current Quail package.
+See also the documentation of `quail-define-package'."
+ (nth 3 quail-current-package))
+(defsubst quail-docstring ()
+ "Return the documentation string of the current Quail package."
+ (nth 4 quail-current-package))
+(defsubst quail-translation-keymap ()
+ "Return translation keymap in the current Quail package.
+Translation keymap is a keymap used while translation region is active."
+ (nth 5 quail-current-package))
+(defsubst quail-forget-last-selection ()
+ "Return `forget-last-selection' flag of the current Quail package.
+See also the documentation of `quail-define-package'."
+ (nth 6 quail-current-package))
+(defsubst quail-deterministic ()
+ "Return `deterministic' flag of the current Quail package.
+See also the documentation of `quail-define-package'."
+ (nth 7 quail-current-package))
+(defsubst quail-kbd-translate ()
+ "Return `kbd-translate' flag of the current Quail package.
+See also the documentation of `quail-define-package'."
+ (nth 8 quail-current-package))
+(defsubst quail-show-layout ()
+ "Return `show-layout' flag of the current Quail package.
+See also the documentation of `quail-define-package'."
+ (nth 9 quail-current-package))
+(defsubst quail-decode-map ()
+ "Return decode map of the current Quail package.
+It is an alist of translations and corresponding keys."
+ (nth 10 quail-current-package))
+(defsubst quail-maximum-shortest ()
+ "Return `maximum-shortest' flag of the current Quail package.
+See also the documentation of `quail-define-package'."
+ (nth 11 quail-current-package))
+(defsubst quail-overlay-plist ()
+ "Return property list of an overly used in the current Quail package."
+ (nth 12 quail-current-package))
+(defsubst quail-update-translation-function ()
+ "Return a function for updating translation in the current Quail package."
+ (nth 13 quail-current-package))
+(defsubst quail-conversion-keymap ()
+ "Return conversion keymap in the current Quail package.
+Conversion keymap is a keymap used while conversion region is active
+ but translation region is not active."
+ (nth 14 quail-current-package))
+
+(defsubst quail-package (name)
+ "Return Quail package named NAME."
+ (assoc name quail-package-alist))
+
+(defun quail-add-package (package)
+ "Add Quail package PACKAGE to `quail-package-alist'."
+ (let ((pac (quail-package (car package))))
+ (if pac
+ (setcdr pac (cdr package))
+ (setq quail-package-alist (cons package quail-package-alist)))))
+
+(defun quail-select-package (name)
+ "Select Quail package named NAME as the current Quail package."
+ (let ((package (quail-package name)))
+ (if (null package)
+ (error "No Quail package `%s'" name))
+ (setq quail-current-package package)
+ (setq-default quail-current-package package)
+ name))
+
+;;;###autoload
+(defun quail-use-package (package-name &rest libraries)
+ "Start using Quail package PACKAGE-NAME.
+The remaining arguments are libraries to be loaded before using the package."
+ (while libraries
+ (if (not (load (car libraries) t))
+ (progn
+ (with-output-to-temp-buffer "*Help*"
+ (princ "Quail package \"")
+ (princ package-name)
+ (princ "\" can't be activated\n because library \"")
+ (princ (car libraries))
+ (princ "\" is not in `load-path'.
+
+The most common case is that you have not yet installed appropriate
+libraries in LEIM (Libraries of Emacs Input Method) which is
+distributed separately from Emacs.
+
+Installation of LEIM for Quail is very simple, just copy Quail
+packages (byte-compiled Emacs Lisp files) to somewhere in your
+`load-path'.
+
+LEIM is available from the same ftp directory as Emacs."))
+ (error ""))
+ (setq libraries (cdr libraries))))
+ (quail-select-package package-name)
+ (setq current-input-method-title (quail-title))
+ (quail-mode 1))
+
+(defun quail-inactivate ()
+ "Turn off Quail input method."
+ (interactive)
+ (throw 'quail-tag t))
+
+(or (assq 'quail-mode minor-mode-alist)
+ (setq minor-mode-alist
+ (cons '(quail-mode " Quail") minor-mode-alist)))
+
+(defvar quail-mode-map
+ (let ((map (make-keymap))
+ (i ? ))
+ (while (< i 127)
+ (define-key map (char-to-string i) 'quail-start-translation)
+ (setq i (1+ i)))
+ map)
+ "Keymap for Quail mode.")
+
+(or (assq 'quail-mode minor-mode-map-alist)
+ (setq minor-mode-map-alist
+ (cons (cons 'quail-mode quail-mode-map) minor-mode-map-alist)))
+
+(defvar quail-translation-keymap
+ (let ((map (make-keymap))
+ (i 0))
+ (while (< i ?\ )
+ (define-key map (char-to-string i) 'quail-execute-non-quail-command)
+ (setq i (1+ i)))
+ (while (< i 127)
+ (define-key map (char-to-string i) 'quail-self-insert-command)
+ (setq i (1+ i)))
+ (define-key map "\177" 'quail-delete-last-char)
+ (define-key map "\C-\\" 'quail-inactivate)
+ (define-key map "\C-f" 'quail-next-translation)
+ (define-key map "\C-b" 'quail-prev-translation)
+ (define-key map "\C-n" 'quail-next-translation-block)
+ (define-key map "\C-p" 'quail-prev-translation-block)
+ (define-key map "\C-i" 'quail-completion)
+ (define-key map "\C-@" 'quail-select-current)
+ (define-key map "\C-c" 'quail-abort-translation)
+ (define-key map "\C-h" 'quail-translation-help)
+ (define-key map [tab] 'quail-completion)
+ (define-key map [delete] 'quail-delete-last-char)
+ (define-key map [backspace] 'quail-delete-last-char)
+ ;; At last, define default key binding.
+ (append map '((t . quail-execute-non-quail-command))))
+ "Keymap used processing translation in Quail mode.
+This map is activated while translation region is active.")
+
+(defvar quail-conversion-keymap
+ (let ((map (make-keymap))
+ (i 0))
+ (while (< i ?\ )
+ (define-key map (char-to-string i) 'quail-execute-non-quail-command)
+ (setq i (1+ i)))
+ (while (< i 127)
+ (define-key map (char-to-string i)
+ 'quail-start-translation-in-conversion-mode)
+ (setq i (1+ i)))
+ (define-key map "\C-b" 'quail-conversion-backward-char)
+ (define-key map "\C-f" 'quail-conversion-forward-char)
+ (define-key map "\C-a" 'quail-conversion-beginning-of-region)
+ (define-key map "\C-e" 'quail-conversion-end-of-region)
+ (define-key map "\C-d" 'quail-conversion-delete-char)
+ (define-key map "\C-h" 'quail-conversion-help)
+ (define-key map "\C-\\" 'quail-inactivate)
+ (define-key map "\177" 'quail-conversion-backward-delete-char)
+ (define-key map [delete] 'quail-conversion-backward-delete-char)
+ (define-key map [backspace] 'quail-conversion-backward-delete-char)
+ ;; At last, define default key binding.
+ (append map '((t . quail-execute-non-quail-command))))
+ "Keymap used for processing conversion in Quail mode.
+This map is activated while convesion region is active but translation
+region is not active.")
+
+(defun quail-define-package (name language title
+ &optional guidance docstring translation-keys
+ forget-last-selection deterministic
+ kbd-translate show-layout create-decode-map
+ maximum-shortest overlay-plist
+ update-translation-function
+ conversion-keys)
+ "Define NAME as a new Quail package for input LANGUAGE.
+TITLE is a string to be displayed at mode-line to indicate this package.
+Optional arguments are GUIDANCE, DOCSTRING, TRANLSATION-KEYS,
+ FORGET-LAST-SELECTION, DETERMINISTIC, KBD-TRANSLATE, SHOW-LAYOUT,
+ CREATE-DECODE-MAP, MAXIMUM-SHORTEST, OVERLAY-PLIST,
+ UPDATE-TRANSLATION-FUNCTION, and CONVERSION-KEYS.
+
+GUIDANCE specifies how a guidance string is shown in echo area.
+If it is t, list of all possible translations for the current key is shown
+ with the currently selected translation being highlighted.
+If it is an alist, the element has the form (CHAR . STRING). Each character
+ in the current key is searched in the list and the corresponding string is
+ shown.
+If it is nil, the current key is shown.
+
+DOCSTRING is the documentation string of this package.
+
+TRANSLATION-KEYS specifies additional key bindings used while translation
+region is active. It is an alist of single key character vs. corresponding
+command to be called.
+
+FORGET-LAST-SELECTION non-nil means a selected translation is not kept
+for the future to translate the same key. If this flag is nil, a
+translation selected for a key is remembered so that it can be the
+first candidate when the same key is entered later.
+
+DETERMINISTIC non-nil means the first candidate of translation is
+selected automatically without allowing users to select another
+translation for a key. In this case, unselected translations are of
+no use for an interactive use of Quail but can be used by some other
+programs. If this flag is non-nil, FORGET-LAST-SELECTION is also set
+to t.
+
+KBD-TRANSLATE non-nil means input characters are translated from a
+user's keyboard layout to the standard keyboard layout. See the
+documentation of `quail-keyboard-layout' and
+`quail-keyboard-layout-standard' for more detail.
+
+SHOW-LAYOUT non-nil means the `quail-help' command should show
+the user's keyboard layout visually with translated characters.
+If KBD-TRANSLATE is set, it is desirable to set also this flag unless
+this package defines no translations for single character keys.
+
+CREATE-DECODE-MAP non-nil means decode map is also created. A decode
+map is an alist of translations and corresponding original keys.
+Although this map is not used by Quail itself, it can be used by some
+other programs. For instance, Vietnamese supporting needs this map to
+convert Vietnamese text to VIQR format which uses only ASCII
+characters to represent Vietnamese characters.
+
+MAXIMUM-SHORTEST non-nil means break key sequence to get maximum
+length of the shortest sequence. When we don't have a translation of
+key \"..ABCD\" but have translations of \"..AB\" and \"CD..\", break
+the key at \"..AB\" and start translation of \"CD..\". Hangul
+packages, for instance, use this facility. If this flag is nil, we
+break the key just at \"..ABC\" and start translation of \"D..\".
+
+OVERLAY-PLIST if non-nil is a property list put on an overlay which
+covers Quail translation region.
+
+UPDATE-TRANSLATION-FUNCTION if non-nil is a function to call to update
+the current translation region accoding to a new translation data. By
+default, a tranlated text or a user's key sequence (if no transltion
+for it) is inserted.
+
+CONVERSION-KEYS specifies additional key bindings used while
+conversion region is active. It is an alist of single key character
+vs. corresponding command to be called."
+ (let (translation-keymap conversion-keymap)
+ (if deterministic (setq forget-last-selection t))
+ (if translation-keys
+ (progn
+ (setq translation-keymap (copy-keymap quail-translation-keymap))
+ (while translation-keys
+ (define-key translation-keymap
+ (car (car translation-keys)) (cdr (car translation-keys)))
+ (setq translation-keys (cdr translation-keys))))
+ (setq translation-keymap quail-translation-keymap))
+ (if conversion-keys
+ (progn
+ (setq conversion-keymap (copy-keymap quail-conversion-keymap))
+ (while conversion-keys
+ (define-key conversion-keymap
+ (car (car conversion-keys)) (cdr (car conversion-keys)))
+ (setq conversion-keys (cdr conversion-keys)))))
+ (quail-add-package
+ (list name title (list nil) guidance (or docstring "")
+ translation-keymap
+ forget-last-selection deterministic kbd-translate show-layout
+ (if create-decode-map (list 'decode-map) nil)
+ maximum-shortest overlay-plist update-translation-function
+ conversion-keymap)))
+ (register-input-method language (list name 'quail-use-package))
+ (quail-select-package name))
+
+;; Quail minor mode handlers.
+
+;; Setup overlays used in Quail mode.
+(defun quail-setup-overlays ()
+ (let ((pos (point)))
+ (if (overlayp quail-overlay)
+ (move-overlay quail-overlay pos pos)
+ (setq quail-overlay (make-overlay pos pos nil nil t))
+ (overlay-put quail-overlay 'face 'underline)
+ (let ((l (quail-overlay-plist)))
+ (while l
+ (overlay-put quail-overlay (car l) (car (cdr l)))
+ (setq l (cdr (cdr l))))))
+ (if (overlayp quail-conv-overlay)
+ (move-overlay quail-conv-overlay pos pos)
+ (setq quail-conv-overlay (make-overlay pos pos nil nil t))
+ (overlay-put quail-conv-overlay 'face 'underline)
+ ;;(overlay-put quail-conv-overlay 'modification-hooks
+ ;;'(quail-conv-overlay-modification-hook))
+ )))
+
+;; Delete overlays used in Quail mode.
+(defun quail-delete-overlays ()
+ (if (overlayp quail-overlay)
+ (delete-overlay quail-overlay))
+ (if (overlayp quail-conv-overlay)
+ (delete-overlay quail-conv-overlay)))
+
+;; While translating and converting, we enter the recursive edit and
+;; exit it frequently, which results in frequent and annoying change
+;; of and annoying in mode line. To avoid it, we use a modified
+;; mode-line-format.
+(defvar quail-mode-line-format nil)
+
+;; Return a modified mode-line-format which doesn't show the recursive
+;; editing level. But, we only pay attention to the top level
+;; elements of the current mode-line-format.
+(defun quail-generate-mode-line-format ()
+ (if (listp mode-line-format)
+ (let ((new (copy-sequence mode-line-format))
+ l elt idx)
+ (setq l new)
+ (while l
+ (setq elt (car l))
+ (if (and (stringp elt)
+ (or (setq idx (string-match "%\\[" elt))
+ (setq idx (string-match "%\\]" elt))))
+ (setcar l (concat (substring elt 0 idx)
+ (substring elt (+ idx 2)))))
+ (setq l (cdr l)))
+ new)
+ mode-line-format))
+
+(defun quail-mode (&optional arg)
+ "Toggle Quail minor mode.
+With arg, turn Quail mode on if and only if arg is positive.
+Try \\[describe-bindings] in Quail mode to see the available key binding.
+The command \\[describe-input-method] describes the current Quail package."
+ (interactive "P")
+ (setq quail-mode
+ (if (null arg) (null quail-mode)
+ (> (prefix-numeric-value arg) 0)))
+ (if (null quail-mode)
+ ;; Let's turn off Quail mode.
+ (progn
+ (quail-hide-guidance-buf)
+ (quail-delete-overlays)
+ (setq describe-current-input-method-function nil)
+ (setq current-input-method nil)
+ (run-hooks 'quail-mode-exit-hook)
+ (run-hooks 'input-method-inactivate-hook))
+ ;; Let's turn on Quail mode.
+ (if (null quail-current-package)
+ ;; Quail package is not yet selected. Select one now.
+ (let (name)
+ (if quail-package-alist
+ (setq name (car (car quail-package-alist)))
+ (setq quail-mode nil)
+ (error "No Quail package loaded"))
+ (quail-select-package name)))
+ (setq inactivate-current-input-method-function 'quail-mode)
+ (setq describe-current-input-method-function 'quail-help)
+ (setq quail-mode-line-format (quail-generate-mode-line-format))
+ (quail-delete-overlays)
+ (quail-show-guidance-buf)
+ ;; If we are in minibuffer, turn off Quail mode before exiting.
+ (if (eq (selected-window) (minibuffer-window))
+ (add-hook 'minibuffer-exit-hook 'quail-exit-from-minibuffer))
+ (make-local-hook 'post-command-hook)
+ (run-hooks 'quail-mode-hook)
+ (run-hooks 'input-method-activate-hook))
+ (force-mode-line-update))
+
+(defun quail-exit-from-minibuffer ()
+ (if quail-mode (quail-mode -1))
+ (if (<= (minibuffer-depth) 1)
+ (remove-hook 'minibuffer-exit-hook 'quail-exit-from-minibuffer)))
+
+(defvar quail-saved-overriding-local-map nil)
+(defvar quail-saved-current-buffer nil)
+
+;; Toggle `quail-mode'. This function is added to `post-command-hook'
+;; in Quail mode, to turn Quail mode temporarily off, or back on
+;; after one non-Quail command.
+(defun quail-toggle-mode-temporarily ()
+ (if quail-mode
+ ;; We are going to handle following events out of Quail mode.
+ (setq quail-mode nil
+ quail-saved-overriding-local-map overriding-local-map
+ quail-saved-current-buffer (current-buffer)
+ overriding-local-map nil)
+ ;; We have just executed one non-Quail command. We don't need
+ ;; this hook any more.
+ (remove-hook 'post-command-hook 'quail-toggle-mode-temporarily t)
+ ;; If the command changed the current buffer, we should not go
+ ;; back to Quail mode.
+ (if (not (eq (current-buffer) quail-saved-current-buffer))
+ (throw 'quail-tag nil)
+ ;; Let's go back to Quail mode.
+ (setq quail-mode t)
+ (setq overriding-local-map quail-saved-overriding-local-map)
+ ;; If whole text in conversion area was deleted, exit from the
+ ;; recursive edit.
+ (let ((start (overlay-start quail-conv-overlay)))
+ (if (and start (= start (overlay-end quail-conv-overlay)))
+ (throw 'quail-tag nil)))
+ )))
+
+(defun quail-execute-non-quail-command ()
+ "Execute one non-Quail command in Quail mode.
+The current translation and conversion are terminated."
+ (interactive)
+ (setq unread-command-events (cons last-input-event unread-command-events))
+ (quail-delete-overlays)
+ (if (buffer-live-p quail-guidance-buf)
+ (save-excursion
+ (set-buffer quail-guidance-buf)
+ (erase-buffer)))
+ (throw 'quail-tag nil))
+
+;; Keyboard layout translation handlers.
+
+;; Some Quail packages provide localized keyboard simulation which
+;; requires a particular keyboard layout. In this case, what we need
+;; is locations of keys the user entered, not character codes
+;; generated by those keys. However, for the moment, there's no
+;; common way to get such information. So, we ask a user to give
+;; information of his own keyboard layout, then translate it to the
+;; standard layout which we defined so that all Quail packages depend
+;; just on it.
+
+(defconst quail-keyboard-layout-standard
+ "\
+ 1!2@3#4$5%6^7&8*9(0)-_=+`~ \
+ qQwWeErRtTyYuUiIoOpP[{]} \
+ aAsSdDfFgGhHjJkKlL;:'\"\\| \
+ zZxXcCvVbBnNmM,<.>/? "
+ "Standard keyboard layout of printable characters Quail assumes.
+See the documentation of `quail-keyboard-layout' for this format.
+This layout is almost the same as that of VT100,
+ but the location of key \\ (backslash) is just right of key ' (single-quote),
+ not right of RETURN key.")
+
+(defvar quail-keyboard-layout quail-keyboard-layout-standard
+ "A string which represents physical key layout of a particular keyboard.
+We assume there are four rows and each row has 15 keys (columns),
+ the first column of the first row is left of key '1',
+ the first column of the second row is left of key `q',
+ the first column of the third row is left of key `a',
+ the first column of the fourth row is left of key `z'.
+Nth (N is even) and (N+1)th characters in the string are non-shifted
+ and shifted characters respectively at the same location.
+The location of Nth character is row (N / 30) and column ((N mod 30) / 2).")
+
+(defconst quail-keyboard-layout-len 120)
+
+;; Here we provide several examples of famous keyboard layouts.
+
+(defvar quail-keyboard-layout-alist
+ (list
+ '("sun-type3" . "\
+ 1!2@3#4$5%6^7&8*9(0)-_=+\\|`~\
+ qQwWeErRtTyYuUiIoOpP[{]} \
+ aAsSdDfFgGhHjJkKlL;:'\" \
+ zZxXcCvVbBnNmM,<.>/? ")
+ (cons "standard" quail-keyboard-layout-standard))
+ "Alist of keyboard names and corresponding layout strings.
+See the documentation of `quail-keyboard-layout' for the format of
+ the layout string.")
+
+(defun quail-set-keyboard-layout (kbd-type)
+ "Set the current keyboard layout to the same as keyboard KBD-TYPE.
+
+Since some Quail packages depends on a physical layout of keys (not
+characters generated by them), those are created by assuming the
+standard layout defined in `quail-keyboard-layout-standard'. This
+function tells Quail system the layout of your keyboard so that what
+you type is correctly handled."
+ (interactive
+ (let* ((completing-ignore-case t)
+ (type (completing-read "Keyboard type: "
+ quail-keyboard-layout-alist)))
+ (list type)))
+ (let ((layout (assoc kbd-type quail-keyboard-layout-alist)))
+ (if (null layout)
+ ;; Here, we had better ask a user to define his own keyboard
+ ;; layout interactively.
+ (error "Unknown keyboard type `%s'" kbd-type))
+ (setq quail-keyboard-layout (cdr layout))))
+
+(defun quail-keyboard-translate (ch)
+ "Translate CHAR according to `quail-keyboard-layout' and return the result."
+ (if (eq quail-keyboard-layout quail-keyboard-layout-standard)
+ ch
+ (let ((i 0))
+ (while (and (< i quail-keyboard-layout-len)
+ (/= ch (aref quail-keyboard-layout i)))
+ (setq i (1+ i)))
+ (if (= i quail-keyboard-layout-len)
+ (error "Character `%c' not found in your keyboard layout" ch))
+ (aref quail-keyboard-layout-standard i))))
+
+;; Quail map
+
+(defsubst quail-map-p (object)
+ "Return t if OBJECT is a Quail map.
+
+A Quail map holds information how a particular key should be translated.
+Its format is (TRANSLATION . ALIST).
+TRANSLATION is either a character, or a cons (INDEX . VECTOR).
+In the latter case, each element of VECTOR is a candidate for the translation,
+and INDEX points the currently selected translation.
+
+ALIST is normally a list of elements that look like (CHAR . DEFN),
+where DEFN is another Quail map for a longer key (CHAR added to the
+current key). It may also be a symbol of a function which returns an
+alist of the above format.
+
+Just after a Quail package is read, TRANSLATION may be a string or a
+vector. Then each element of the string or vector is a candidate for
+the translation. These objects are transformed to cons cells in the
+format \(INDEX . VECTOR), as described above."
+ (and (consp object)
+ (let ((translation (car object)))
+ (or (integerp translation) (consp translation) (null translation)
+ (vectorp translation) (stringp translation)
+ (symbolp translation)))
+ (let ((alist (cdr object)))
+ (or (listp alist) (symbolp alist)))))
+
+(defmacro quail-define-rules (&rest rules)
+ "Define translation rules of the current Quail package.
+Each argument is a list of KEY and TRANSLATION.
+KEY is a string meaning a sequence of keystrokes to be translated.
+TRANSLATION is a character, a string, a vector, a Quail map, or a function.
+It it is a character, it is the sole translation of KEY.
+If it is a string, each character is a candidate for the translation.
+If it is a vector, each element (string or character) is a candidate
+ for the translation.
+In these cases, a key specific Quail map is generated and assigned to KEY.
+
+If TRANSLATION is a Quail map or a function symbol which returns a Quail map,
+ it is used to handle KEY."
+ `(quail-install-map
+ ',(let ((l rules)
+ (map (list nil)))
+ (while l
+ (quail-defrule-internal (car (car l)) (car (cdr (car l))) map)
+ (setq l (cdr l)))
+ map)))
+
+(defun quail-install-map (map)
+ "Install the Quail map MAP in the current Quail package.
+The installed map can be referred by the function `quail-map'."
+ (if (null quail-current-package)
+ (error "No current Quail package"))
+ (if (null (quail-map-p map))
+ (error "Invalid Quail map `%s'" map))
+ (setcar (cdr (cdr quail-current-package)) map))
+
+(defun quail-defrule (key translation &optional name)
+ "Add one translation rule, KEY to TRANSLATION, in the current Quail package.
+KEY is a string meaning a sequence of keystrokes to be translated.
+TRANSLATION is a character, a string, a vector, a Quail map, or a function.
+It it is a character, it is the sole translation of KEY.
+If it is a string, each character is a candidate for the translation.
+If it is a vector, each element (string or character) is a candidate
+ for the translation.
+In these cases, a key specific Quail map is generated and assigned to KEY.
+
+If TRANSLATION is a Quail map or a function symbol which returns a Quail map,
+ it is used to handle KEY.
+Optional argument NAME, if specified, says which Quail package
+to define this translation rule in. The default is to define it in the
+current Quail package."
+ (if name
+ (let ((package (quail-package name)))
+ (if (null package)
+ (error "No Quail package `%s'" name))
+ (setq quail-current-package package)))
+ (quail-defrule-internal key translation (quail-map)))
+
+;; Define KEY as TRANS in a Quail map MAP.
+(defun quail-defrule-internal (key trans map)
+ (if (null (stringp key))
+ "Invalid Quail key `%s'" key)
+ (if (not (or (numberp trans) (stringp trans) (vectorp trans)
+ (symbolp trans)
+ (quail-map-p trans)))
+ (error "Invalid Quail translation `%s'" trans))
+ (if (null (quail-map-p map))
+ (error "Invalid Quail map `%s'" map))
+ (let ((len (length key))
+ (idx 0)
+ ch entry)
+ (while (< idx len)
+ (if (null (consp map))
+ ;; We come here, for example, when we try to define a rule
+ ;; for "ABC" but a rule for "AB" is already defined as a
+ ;; symbol.
+ (error "Quail key %s is too long" key))
+ (setq ch (aref key idx)
+ entry (assq ch (cdr map)))
+ (if (null entry)
+ (progn
+ (setq entry (cons ch (list nil)))
+ (setcdr map (cons entry (cdr map)))))
+ (setq map (cdr entry))
+ (setq idx (1+ idx)))
+ (if (symbolp trans)
+ (if (cdr map)
+ ;; We come here, for example, when we try to define a rule
+ ;; for "AB" as a symbol but a rule for "ABC" is already
+ ;; defined.
+ (error "Quail key %s is too short" key)
+ (setcdr entry trans))
+ (if (quail-map-p trans)
+ (if (not (listp (cdr map)))
+ ;; We come here, for example, when we try to define a rule
+ ;; for "AB" as a symbol but a rule for "ABC" is already
+ ;; defined.
+ (error "Quail key %s is too short" key)
+ (if (not (listp (cdr trans)))
+ (if (cdr map)
+ ;; We come here, for example, when we try to
+ ;; define a rule for "AB" as a symbol but a rule
+ ;; for "ABC" is already defined.
+ (error "Quail key %s is too short" key)
+ (setcdr entry trans))
+ (setcdr entry (append trans (cdr map)))))
+ (setcar map trans)))))
+
+(defun quail-get-translation (map key len)
+ "Return the translation specified in Quail map MAP for KEY of length LEN.
+The translation is either a character or a cons of the form (INDEX . VECTOR),
+where VECTOR is a vector of candidates (character or string) for
+the translation, and INDEX points into VECTOR to specify the currently
+selected translation."
+ (let ((def (car map)))
+ (if (and def (symbolp def))
+ ;; DEF is a symbol of a function which returns valid translation.
+ (setq def (funcall def key len)))
+ (cond
+ ((or (integerp def) (consp def))
+ def)
+
+ ((null def)
+ ;; No translation.
+ nil)
+
+ ((stringp def)
+ ;; Each character in DEF is a candidate of translation. Reform
+ ;; it as (INDEX . VECTOR).
+ (setq def (string-to-vector def))
+ ;; But if the length is 1, we don't need vector but a single
+ ;; character as the translation.
+ (if (= (length def) 1)
+ (aref def 0)
+ (cons 0 def)))
+
+ ((vectorp def)
+ ;; Each element (string or character) in DEF is a candidate of
+ ;; translation. Reform it as (INDEX . VECTOR).
+ (cons 0 def))
+
+ (t
+ (error "Invalid object in Quail map: %s" def)))))
+
+(defun quail-lookup-key (key len)
+ "Lookup KEY of length LEN in the current Quail map and return the definition.
+The returned value is a Quail map specific to KEY."
+ (let ((idx 0)
+ (map (quail-map))
+ (kbd-translate (quail-kbd-translate))
+ slot ch translation)
+ (while (and map (< idx len))
+ (setq ch (if kbd-translate (quail-keyboard-translate (aref key idx))
+ (aref key idx)))
+ (setq idx (1+ idx))
+ (if (and (cdr map) (symbolp (cdr map)))
+ (setcdr map (funcall (cdr map) key idx)))
+ (setq slot (assq ch (cdr map)))
+ (if (and (cdr slot) (symbolp (cdr slot)))
+ (setcdr slot (funcall (cdr slot) key idx)))
+ (setq map (cdr slot)))
+ (if (and map (setq translation (quail-get-translation map key len)))
+ (progn
+ ;; We may have to reform car part of MAP.
+ (if (not (equal (car map) translation))
+ (setcar map translation))
+ (if (consp translation)
+ (progn
+ (setq quail-current-translations translation)
+ (if (quail-forget-last-selection)
+ (setcar quail-current-translations 0))))
+ ;; We may have to reform cdr part of MAP.
+ (if (and (cdr map) (symbolp (cdr map)))
+ (progn
+ (setcdr map (funcall (cdr map) key len))))
+ ))
+ map))
+
+(defun quail-conv-overlay-modification-hook (overlay after &rest ignore)
+ (if (and after
+ (= (overlay-start overlay) (overlay-end overlay)))
+ ;; Whole text in conversion area was deleted. Let's exit from
+ ;; the recursive edit.
+ (throw 'exit nil)))
+
+(defvar quail-suppress-conversion nil
+ "If non-nil, suppress converting facility of the current Quail package.")
+
+;; If set to non-nil, exit conversion mode before starting new translation.
+(defvar quail-exit-conversion-mode nil)
+
+(defun quail-start-translation ()
+ "Start translating the typed character in Quail mode."
+ (interactive "*")
+ (setq unread-command-events
+ (cons last-command-event unread-command-events))
+ ;; Check the possibility of translating the last key.
+ (if (assq last-command-event (cdr (quail-map)))
+ ;; Ok, we can start translation.
+ (let ((mode-line-format quail-mode-line-format))
+ (quail-setup-overlays)
+ (if (catch 'quail-tag
+ (if (and (not quail-suppress-conversion)
+ (quail-conversion-keymap))
+ ;; We must start translation in conversion mode.
+ (let ((overriding-local-map (quail-conversion-keymap)))
+ (setq quail-exit-conversion-mode nil)
+ (recursive-edit)
+ (if (and auto-fill-function
+ (> (current-column) (current-fill-column)))
+ (run-hooks 'auto-fill-function)))
+ (let ((overriding-local-map (quail-translation-keymap)))
+ (setq quail-current-key "")
+ (recursive-edit)))
+ (if (prog1 (< (overlay-start quail-conv-overlay)
+ (overlay-end quail-conv-overlay))
+ (delete-overlay quail-conv-overlay))
+ (run-hooks 'input-method-after-insert-chunk-hook))
+ nil)
+ ;; Someone has thrown a tag with value t, which means
+ ;; we should turn Quail mode off.
+ (quail-mode -1)))
+ ;; Since the typed character doesn't start any translation, handle
+ ;; it out of Quail mode. We come back to Quail mode later because
+ ;; function `quail-toggle-mode-temporarily' is in
+ ;; `post-command-hook'.
+ (add-hook 'post-command-hook 'quail-toggle-mode-temporarily nil t)))
+
+(defsubst quail-point-in-conversion-region ()
+ "Return non-nil value if the point is in conversion region of Quail mode."
+ (let (start pos)
+ (and (setq start (overlay-start quail-conv-overlay))
+ (>= (setq pos (point)) start)
+ (<= pos (overlay-end quail-conv-overlay)))))
+
+(defun quail-start-translation-in-conversion-mode ()
+ "Start translating the typed character in conversion mode of Quail mode."
+ (interactive "*")
+ (setq unread-command-events
+ (cons last-command-event unread-command-events))
+ (if (or quail-exit-conversion-mode
+ (not (quail-point-in-conversion-region)))
+ (progn
+ ;; We must start translation with new conversion region.
+ (setq quail-exit-conversion-mode nil)
+ (throw 'exit nil)))
+ ;; Check the possibility of translating the last key.
+ (if (assq last-command-event (cdr (quail-map)))
+ ;; Ok, we can start translation.
+ (let ((overriding-local-map (quail-translation-keymap)))
+ (setq quail-current-key "")
+ (move-overlay quail-overlay (point) (point))
+ (recursive-edit))
+ ;; Since the typed character doesn't start any translation, handle
+ ;; it out of Quail mode. We come back to Quail mode later because
+ ;; function `quail-toggle-mode-temporarily' is in
+ ;; `post-command-hook'.
+ (add-hook 'post-command-hook 'quail-toggle-mode-temporarily nil t)))
+
+(defun quail-terminate-translation ()
+ "Terminate the translation of the current key."
+ (let ((start (overlay-start quail-overlay)))
+ (if (and start
+ (< start (overlay-end quail-overlay)))
+ ;; Here we simulate self-insert-command.
+ (let (last-command-char)
+ (goto-char start)
+ ;; The first one might want to expand an abbrev.
+ (setq last-command-char (following-char))
+ (delete-char 1)
+ (self-insert-command 1)
+ (if (< (point) (overlay-end quail-overlay))
+ (if overwrite-mode
+ (while (< (point) (overlay-end quail-overlay))
+ (setq last-command-char (following-char))
+ (delete-char 1)
+ (self-insert-command 1))
+ ;; The last one might still want to auto-fill.
+ (goto-char (overlay-end quail-overlay))
+ (let ((last-command-char (preceding-char)))
+ (delete-char -1)
+ (self-insert-command 1)))))))
+ (delete-overlay quail-overlay)
+ (if (buffer-live-p quail-guidance-buf)
+ (save-excursion
+ (set-buffer quail-guidance-buf)
+ (erase-buffer)))
+ (throw 'exit nil))
+
+(defsubst quail-delete-region ()
+ "Delete the text in the current translation region of Quail."
+ (delete-region (overlay-start quail-overlay) (overlay-end quail-overlay)))
+
+(defun quail-select-current ()
+ "Select the current text shown in Quail translation region."
+ (interactive)
+ (quail-terminate-translation))
+
+;; Update the current translation status according to CONTROL-FLAG.
+;; If CONTROL-FLAG is integer value, it is the number of keys in the
+;; head quail-current-key which can be translated. The remaining keys
+;; are put back to unread-command-events to be handled again.
+;; If CONTROL-FLAG is t, terminate the translation for the whole keys
+;; in quail-current-key.
+;; If CONTROL-FLAG is nil, proceed the translation with more keys.
+
+(defun quail-update-translation (control-flag)
+ (quail-delete-region)
+ (let ((func (quail-update-translation-function)))
+ (if func
+ (funcall func control-flag)
+ (if (numberp control-flag)
+ (let ((len (length quail-current-key)))
+ (while (> len control-flag)
+ (setq len (1- len))
+ (setq unread-command-events
+ (cons (aref quail-current-key len)
+ unread-command-events)))
+ (insert (or quail-current-str
+ (substring quail-current-key 0 len))))
+ (insert (or quail-current-str quail-current-key)))))
+ (quail-update-guidance)
+ (if control-flag
+ (quail-terminate-translation)))
+
+(defun quail-self-insert-command ()
+ "Add the typed character to the key for translation."
+ (interactive "*")
+ (setq quail-current-key
+ (concat quail-current-key (char-to-string last-command-event)))
+ (quail-update-translation (quail-translate-key)))
+
+(defun quail-translate-key ()
+ "Translate the current key sequence according to the current Quail map.
+Return t if we can terminate the translation.
+Return nil if the current key sequence may be followed by more keys.
+Return number if we can't find any translation for the current key
+sequence. The number is the count of valid keys in the current
+sequence counting from the head."
+ (let* ((len (length quail-current-key))
+ (map (quail-lookup-key quail-current-key len))
+ def ch)
+ (if map
+ (let ((def (car map)))
+ (setq quail-current-str
+ (if (consp def) (aref (cdr def) (car def)) def))
+ ;; Return t only if we can terminate the current translation.
+ (and
+ ;; No alternative translations.
+ (or (null (consp def)) (= (length (cdr def)) 1))
+ ;; No translation for the longer key.
+ (null (cdr map))
+ ;; No shorter breaking point.
+ (or (null (quail-maximum-shortest))
+ (< len 3)
+ (null (quail-lookup-key quail-current-key (1- len)))
+ (null (quail-lookup-key
+ (substring quail-current-key -2 -1) 1)))))
+
+ ;; There's no translation for the current key sequence. Before
+ ;; giving up, we must check two possibilities.
+ (cond ((and
+ (quail-maximum-shortest)
+ (>= len 4)
+ (setq def (car (quail-lookup-key quail-current-key (- len 2))))
+ (quail-lookup-key (substring quail-current-key -2) 2))
+ ;; Now the sequence is "...ABCD", which can be split into
+ ;; "...AB" and "CD..." to get valid translation.
+ ;; At first, get translation of "...AB".
+ (setq quail-current-str
+ (if (consp def) (aref (cdr def) (car def)) def))
+ ;; Then, return the length of "...AB".
+ (- len 2))
+
+ ((and quail-current-translations
+ (not (quail-deterministic))
+ (setq ch (aref quail-current-key (1- len)))
+ (>= ch ?0) (<= ch ?9))
+ ;; A numeric key is entered to select a desirable translation.
+ (setq quail-current-key (substring quail-current-key 0 -1))
+ (quail-select-translation
+ (+ (* (/ (car quail-current-translations) 10) 10)
+ ;; We treat key 1,2..,9,0 as specifying 0,1,..8,9.
+ (if (= ch ?0) 9 (- ch ?1))))
+ ;; And, we can terminate the current translation.
+ t)
+
+ (t
+ ;; No way to handle the last character in this context.
+ (1- len))))))
+
+(defun quail-next-translation ()
+ "Select next translation in the current batch of candidates."
+ (interactive)
+ (if quail-current-translations
+ (progn
+ (quail-select-translation (1+ (car quail-current-translations)))
+ (quail-update-translation nil))
+ (beep)))
+
+(defun quail-prev-translation ()
+ "Select previous translation in the current batch of candidates."
+ (interactive)
+ (if quail-current-translations
+ (progn
+ (quail-select-translation (1- (car quail-current-translations)))
+ (quail-update-translation nil))
+ (beep)))
+
+(defun quail-next-translation-block ()
+ "Select the next batch of 10 translation candidates."
+ (interactive)
+ (if quail-current-translations
+ (let ((limit (1- (length (cdr quail-current-translations))))
+ (n (car quail-current-translations)))
+ (if (< (/ n 10) (/ limit 10))
+ (progn
+ (quail-select-translation (min (+ n 10) limit))
+ (quail-update-translation nil))
+ ;; We are already at the last block.
+ (beep)))
+ (beep)))
+
+(defun quail-prev-translation-block ()
+ "Select the previous batch of 10 translation candidates."
+ (interactive)
+ (if (and quail-current-translations
+ (>= (car quail-current-translations) 10))
+ (progn
+ (quail-select-translation (- (car quail-current-translations) 10))
+ (quail-update-translation nil))
+ (beep)))
+
+(defun quail-select-translation (n)
+ "Select Nth translation in the current batch of translation candidates."
+ (if (or (< n 0) (>= n (length (cdr quail-current-translations))))
+ (beep)
+ (setcar quail-current-translations n)
+ (setq quail-current-str (aref (cdr quail-current-translations) n))))
+
+(defun quail-abort-translation ()
+ "Abort translation and delete the current Quail key sequence."
+ (interactive)
+ (quail-delete-region)
+ (quail-terminate-translation))
+
+(defun quail-delete-last-char ()
+ "Delete the last input character from the current Quail key sequence."
+ (interactive)
+ (if (= (length quail-current-key) 1)
+ (quail-abort-translation)
+ (setq quail-current-key (substring quail-current-key 0 -1))
+ (quail-update-translation (quail-translate-key))))
+
+;; For conversion mode.
+
+(defun quail-conversion-backward-char ()
+ (interactive)
+ (if (<= (point) (overlay-start quail-conv-overlay))
+ (error "Beginning of conversion region"))
+ (forward-char -1))
+
+(defun quail-conversion-forward-char ()
+ (interactive)
+ (if (>= (point) (overlay-end quail-conv-overlay))
+ (error "End of conversion region"))
+ (forward-char 1))
+
+(defun quail-conversion-beginning-of-region ()
+ (interactive)
+ (goto-char (overlay-start quail-conv-overlay)))
+
+(defun quail-conversion-end-of-region ()
+ (interactive)
+ (goto-char (overlay-end quail-conv-overlay)))
+
+(defun quail-conversion-delete-char ()
+ (interactive)
+ (if (>= (point) (overlay-end quail-conv-overlay))
+ (error "End of conversion region"))
+ (delete-char 1)
+ (if (= (overlay-start quail-conv-overlay)
+ (overlay-end quail-conv-overlay))
+ (throw 'quail-tag nil)))
+
+(defun quail-conversion-backward-delete-char ()
+ (interactive)
+ (if (<= (point) (overlay-start quail-conv-overlay))
+ (error "Beginning of conversion region"))
+ (delete-char -1)
+ (if (= (overlay-start quail-conv-overlay)
+ (overlay-end quail-conv-overlay))
+ (throw 'quail-tag nil)))
+
+(defun quail-do-conversion (func &rest args)
+ "Call FUNC to convert text in the current conversion region of Quail.
+Remaining args are for FUNC."
+ (delete-overlay quail-overlay)
+ (apply func args))
+
+(defun quail-no-conversion ()
+ "Do no conversion of the current conversion region of Quail."
+ (interactive)
+ (throw 'exit nil))
+
+;; Guidance, Completion, and Help buffer handlers.
+
+(defun quail-show-guidance-buf ()
+ "Display a Quail guidance buffer in some window.
+Create the buffer if it does not exist yet.
+The window is normally shown in a minibuffer,
+but if the selected window is a minibuffer, it is shown in
+the bottommost ordinary window."
+
+ (if (or (null input-method-tersely-flag)
+ (not (eq (selected-window) (minibuffer-window))))
+ (progn
+ ;; At first, setup a guidance buffer.
+ (or (buffer-live-p quail-guidance-buf)
+ (setq quail-guidance-buf
+ (get-buffer-create " *Quail-guidance*")))
+ (save-excursion
+ (let ((title (quail-title)))
+ (set-buffer quail-guidance-buf)
+ ;; Show the title of Quail package in the left of mode-line.
+ (setq current-input-method nil)
+ (setq current-input-method-title title)
+ (setq mode-line-format (cons '("[" current-input-method-title "]")
+ default-mode-line-format))
+ (erase-buffer)
+ (or (overlayp quail-overlay)
+ (progn
+ (setq quail-overlay (make-overlay 1 1))
+ (overlay-put quail-overlay 'face 'highlight)))
+ (delete-overlay quail-overlay)
+ (set-buffer-modified-p nil)))
+ (bury-buffer quail-guidance-buf)
+
+ ;; Then, display it in an appropriate window.
+ (if (not (get-buffer-window quail-guidance-buf))
+ ;; Guidance buffer is not yet shown in any window.
+ (let ((win (minibuffer-window)))
+ (if (eq (selected-window) win)
+ ;; Since we are in minibuffer, we can't use it for guidance.
+ ;; Let's find the bottom window.
+ (let (height)
+ (setq win (window-at 0 (- (frame-height) 2)))
+ (setq height (window-height win))
+ ;; If WIN is too tall, split it vertically and use
+ ;; the lower one.
+ (if (>= height 4)
+ (let ((window-min-height 2))
+ ;; Here, `split-window' returns a lower window
+ ;; which is what we wanted.
+ (setq win (split-window win (- height 2)))))
+ (set-window-buffer win quail-guidance-buf)
+ (set-window-dedicated-p win t))
+ (set-window-buffer win quail-guidance-buf))))))
+
+ ;; And, create a buffer for completion.
+ (or (buffer-live-p quail-completion-buf)
+ (progn
+ (setq quail-completion-buf (get-buffer-create "*Quail Completions*"))
+ (save-excursion
+ (set-buffer quail-completion-buf)
+ (setq quail-overlay (make-overlay 1 1))
+ (overlay-put quail-overlay 'face 'highlight))))
+ (bury-buffer quail-completion-buf))
+
+(defun quail-hide-guidance-buf ()
+ "Hide the Quail guidance buffer."
+ (let* ((win (minibuffer-window))
+ (buf (window-buffer win)))
+ (if (eq buf quail-guidance-buf)
+ ;; Quail guidance buffer is at echo area. Vacate it to the
+ ;; deepest minibuffer.
+ (set-window-buffer win (format " *Minibuf-%d*" (minibuffer-depth)))
+ ;; Delete the window for guidance buffer.
+ (if (or (null input-method-tersely-flag)
+ (not (eq (selected-window) (minibuffer-window))))
+ (progn
+ (setq win (get-buffer-window quail-guidance-buf))
+ (set-window-dedicated-p win nil)
+ (delete-window win))))))
+
+(defun quail-update-guidance ()
+ "Update the Quail guidance buffer and completion buffer (if displayed now)."
+ ;; Update guidance buffer.
+ (if (or (null input-method-tersely-flag)
+ (not (eq (selected-window) (minibuffer-window))))
+ (let ((guidance (quail-guidance)))
+ (cond ((eq guidance t)
+ ;; Show the current possible translations.
+ (quail-show-translations))
+ ((null guidance)
+ ;; Show the current input keys.
+ (let ((key quail-current-key))
+ (save-excursion
+ (set-buffer quail-guidance-buf)
+ (erase-buffer)
+ (insert key))))
+ ((listp guidance)
+ ;; Show alternative characters specified in this alist.
+ (let* ((key quail-current-key)
+ (len (length key))
+ (i 0)
+ ch alternative)
+ (save-excursion
+ (set-buffer quail-guidance-buf)
+ (erase-buffer)
+ (while (< i len)
+ (setq ch (aref key i))
+ (setq alternative (cdr (assoc ch guidance)))
+ (insert (or alternative ch))
+ (setq i (1+ i)))))))))
+
+ ;; Update completion buffer if displayed now. We highlight the
+ ;; selected candidate string in *Completion* buffer if any.
+ (let ((win (get-buffer-window quail-completion-buf))
+ key str pos)
+ (if win
+ (save-excursion
+ (setq str (if (stringp quail-current-str)
+ quail-current-str
+ (if (numberp quail-current-str)
+ (char-to-string quail-current-str)))
+ key quail-current-key)
+ (set-buffer quail-completion-buf)
+ (goto-char (point-min))
+ (if (null (search-forward (concat " " key ":") nil t))
+ (delete-overlay quail-overlay)
+ (setq pos (point))
+ (if (and str (search-forward (concat "." str) nil t))
+ (move-overlay quail-overlay (1+ (match-beginning 0)) (point))
+ (move-overlay quail-overlay (match-beginning 0) (point)))
+ ;; Now POS points end of KEY and (point) points end of STR.
+ (if (pos-visible-in-window-p (point) win)
+ ;; STR is already visible.
+ nil
+ ;; We want to make both KEY and STR visible, but if the
+ ;; window is too short, make at least STR visible.
+ (setq pos (progn (point) (goto-char pos)))
+ (beginning-of-line)
+ (set-window-start win (point))
+ (if (not (pos-visible-in-window-p pos win))
+ (set-window-start win pos))
+ ))))))
+
+(defun quail-show-translations ()
+ "Show the current possible translations."
+ (let ((key quail-current-key)
+ (map (quail-lookup-key quail-current-key (length quail-current-key))))
+ (save-excursion
+ (set-buffer quail-guidance-buf)
+ (erase-buffer)
+
+ ;; Show the current key.
+ (insert key)
+
+ ;; Show possible following keys.
+ (if (cdr map)
+ (let ((l (cdr map)))
+ (insert "[")
+ (while l
+ (insert (car (car l)))
+ (setq l (cdr l)))
+ (insert "]")))
+
+ ;; Show list of translations.
+ (if (consp (car map))
+ (let* ((idx (car (car map)))
+ (translations (cdr (car map)))
+ (from (* (/ idx 10) 10))
+ (to (min (+ from 10) (length translations))))
+ (indent-to 10)
+ (insert (format "(%d/%d)"
+ (1+ (/ from 10))
+ (1+ (/ (length translations) 10))))
+ (while (< from to)
+ ;; We show the last digit of FROM, but by changing
+ ;; 0,1,..,9 to 1,2,..,0.
+ (insert (format " %d."
+ (if (= (% from 10) 9) 0 (1+ (% from 10)))))
+ (let ((pos (point)))
+ (insert (aref translations from))
+ (if (= idx from)
+ (move-overlay quail-overlay pos (point))))
+ (setq from (1+ from)))))
+ )))
+
+(defun quail-completion ()
+ "List all completions for the current key.
+All possible translations of the current key and whole possible longer keys
+ are shown."
+ (interactive)
+ (let ((key quail-current-key)
+ (map (quail-lookup-key quail-current-key (length quail-current-key))))
+ (save-excursion
+ (set-buffer quail-completion-buf)
+ (erase-buffer)
+ (insert "Possible completion and corresponding translations are:\n")
+ (quail-completion-1 key map 1)
+ (goto-char (point-min))
+ (display-buffer (current-buffer)))
+ (quail-update-guidance)))
+
+;; List all completions of KEY in MAP with indentation INDENT.
+(defun quail-completion-1 (key map indent)
+ (let ((len (length key)))
+ (indent-to indent)
+ (insert key ":")
+ (if (and (symbolp map) (fboundp map))
+ (setq map (funcall map key len)))
+ (if (car map)
+ (quail-completion-list-translations map key (+ indent len 1))
+ (insert " -\n"))
+ (setq indent (+ indent 2))
+ (if (cdr map)
+ (let ((l (cdr map))
+ (newkey (make-string (1+ len) 0))
+ (i 0))
+ ;; Set KEY in the first LEN characters of NEWKEY.
+ (while (< i len)
+ (aset newkey i (aref key i))
+ (setq i (1+ i)))
+ (while l ; L = ((CHAR . DEFN) ....) ;
+ (aset newkey len (car (car l)))
+ (quail-completion-1 newkey (cdr (car l)) indent)
+ (setq l (cdr l)))))))
+
+;; List all possible translations of KEY in Quail map MAP with
+;; indentation INDENT."
+(defun quail-completion-list-translations (map key indent)
+ (let ((translations
+ (quail-get-translation map key (length key))))
+ (if (integerp translations)
+ (insert "(1/1) 1." translations "\n")
+ ;; We need only vector part.
+ (setq translations (cdr translations))
+ ;; Insert every 10 elements with indices in a line.
+ (let ((len (length translations))
+ (i 0)
+ (first t)
+ num)
+ (while (< i len)
+ (if first
+ (progn
+ (insert "(1/1)")
+ (setq first nil))
+ (if (= (% i 10) 0)
+ (progn
+ (newline)
+ (indent-to indent)
+ (insert (format "(%d/%d)" (1+ (/ i 10)) (1+ (/ len 10)))))))
+ ;; We show the last digit of FROM while converting
+ ;; 0,1,..,9 to 1,2,..,0.
+ (insert (format " %d." (if (= (% i 10) 9) 0 (1+ (% i 10)))))
+ (insert (aref translations i))
+ (setq i (1+ i)))
+ (newline)))))
+
+(defun quail-help ()
+ "Show brief description of the current Quail package."
+ (interactive)
+ (let ((package quail-current-package)
+ (buf (get-buffer-create "*Quail-help*")))
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer)
+ (setq quail-current-package package)
+ (insert "Quail input method (name:"
+ (quail-name)
+ ", mode line indicator:["
+ (quail-title)
+ "])\n---- Documentation ----\n"
+ (quail-docstring))
+ (newline)
+ (if (quail-show-layout) (quail-show-kbd-layout))
+ (insert )
+ (quail-help-insert-keymap-description
+ quail-mode-map
+ "---- Key bindings (before starting translation) ----
+key binding
+--- -------\n")
+ (quail-help-insert-keymap-description
+ (quail-translation-keymap)
+ "--- Key bindings (while translating) ---
+key binding
+--- -------\n")
+ (if (quail-conversion-keymap)
+ (quail-help-insert-keymap-description
+ (quail-conversion-keymap)
+ "--- Key bindings (while converting) ---
+key binding
+--- -------\n"))
+ (goto-char (point-min))
+ (set-buffer-modified-p nil)
+ (help-mode))
+ (display-buffer buf)))
+
+(defun quail-help-insert-keymap-description (keymap &optional header)
+ (let (from to)
+ (if header
+ (insert header))
+ (save-excursion
+ (save-window-excursion
+ (let ((overriding-local-map keymap))
+ (describe-bindings))
+ (set-buffer "*Help*")
+ (goto-char (point-min))
+ (forward-line 4)
+ (setq from (point))
+ (search-forward "Global Bindings:" nil 'move)
+ (beginning-of-line)
+ (setq to (point))))
+ (insert-buffer-substring "*Help*" from to)))
+
+(defun quail-show-kbd-layout ()
+ "Show keyboard layout with key tops of multilingual characters."
+ (insert "--- Keyboard layout ---\n")
+ (let* ((i 0) ch)
+ (while (< i quail-keyboard-layout-len)
+ (if (= (% i 30) 0)
+ (progn
+ (newline)
+ (indent-to (/ i 30)))
+ (if (= (% i 2) 0)
+ (insert " ")))
+ (setq ch (aref quail-keyboard-layout i))
+ (if (= ch ?\ )
+ (insert ch)
+ (let ((map (cdr (assq ch (cdr (quail-map))))))
+ (if map
+ (let ((translation
+ (quail-get-translation map (char-to-string ch) 1)))
+ (if (integerp translation)
+ (insert translation)
+ (insert (aref (cdr translation) (car translation)))))
+ (insert ch))))
+ (setq i (1+ i))))
+ (newline))
+
+(defun quail-translation-help ()
+ "Show help message while translating in Quail mode."
+ (interactive)
+ (let ((package quail-current-package)
+ (current-key quail-current-key)
+ (buf (get-buffer-create "*Quail-Help*")))
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer)
+ (setq quail-current-package package)
+ (insert
+ (format "You are translating the key sequence \"%s\" in Quail mode.\n"
+ quail-current-key))
+ (quail-help-insert-keymap-description
+ (quail-translation-keymap)
+ "-----------------------
+key binding
+--- -------\n")
+ (goto-char (point-min))
+ (set-buffer-modified-p nil))
+ (display-buffer buf)))
+
+(defun quail-conversion-help ()
+ "Show help message while converting in Quail mode."
+ (interactive)
+ (let ((package quail-current-package)
+ (str (buffer-substring (overlay-start quail-conv-overlay)
+ (overlay-end quail-conv-overlay)))
+ (buf (get-buffer-create "*Quail-Help*")))
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer)
+ (setq quail-current-package package)
+ (insert
+ (format "You are converting the string \"%s\" in Quail mode.\n" str))
+ (quail-help-insert-keymap-description
+ (quail-conversion-keymap)
+ "-----------------------
+key binding
+--- -------\n")
+ (goto-char (point-min))
+ (set-buffer-modified-p nil))
+ (display-buffer buf)))
+
+;;
+(provide 'quail)
+
+;;; quail.el ends here
--- /dev/null
+;; skkdic-cnv.el -- convert a SKK dictionary for `skkdic-utl'
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: mule, multilingual, Japanese, SKK
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; SKK is a Japanese input method running on Mule created by Masahiko
+;; Sato <masahiko@sato.riec.tohoku.ac.jp>. Here we provide utilities
+;; to handle a dictionary distributed with SKK so that a different
+;; input method (e.g. quail-japanese) can utilize the dictionary.
+
+;; The format of SKK dictionary is quite simple. Each line has the
+;; form "KANASTRING /CONV1/CONV2/.../" which means KANASTRING (\e$B2>L>J8\e(B
+;; \e$B;zNs\e(B) can be converted to one of CONVi. CONVi is a Kanji (\e$B4A;z\e(B)
+;; and Kana (\e$B2>L>\e(B) mixed string.
+;;
+;; KANASTRING may have a trailing ASCII letter for Okurigana (\e$BAw$j2>L>\e(B)
+;; information. For instance, the trailing letter `k' means that one
+;; of the following Okurigana is allowed: \e$B$+$-$/$1$3\e(B. So, in that
+;; case, the string "KANASTRING\e$B$/\e(B" can be converted to one of "CONV1\e$B$/\e(B",
+;; CONV2\e$B$/\e(B, ...
+
+;;; Code:
+
+;; Name of a file to generate from SKK dictionary.
+(defvar skkdic-filename "skkdic.el")
+
+;; To make a generated skkdic.el smaller.
+(make-coding-system
+ 'coding-system-iso-2022-7-short
+ 2 ?J
+ "Like `coding-system-iso-2022' but no ASCII designation before SPC."
+ '(ascii nil nil nil t t nil t))
+
+(defconst skkdic-jbytes
+ (charset-bytes 'japanese-jisx0208))
+
+(defun skkdic-convert-okuri-ari (skkbuf buf)
+ (message "Processing OKURI-ARI entries ...")
+ (goto-char (point-min))
+ (save-excursion
+ (set-buffer buf)
+ (insert ";; Setting okuri-ari entries.\n"
+ "(skkdic-set-okuri-ari\n"))
+ (while (not (eobp))
+ (let ((from (point))
+ to)
+ (end-of-line)
+ (setq to (point))
+
+ (save-excursion
+ (set-buffer buf)
+ (insert-buffer-substring skkbuf from to)
+ (beginning-of-line)
+ (insert "\"")
+ (search-forward " ")
+ (delete-char 1) ; delete the first '/'
+ (let ((p (point)))
+ (end-of-line)
+ (delete-char -1) ; delete the last '/'
+ (subst-char-in-region p (point) ?/ ? 'noundo))
+ (insert "\"\n"))
+
+ (forward-line 1)))
+ (save-excursion
+ (set-buffer buf)
+ (insert ")\n\n")))
+
+(defconst skkdic-postfix-list '(skkdic-postfix-list))
+
+(defconst skkdic-postfix-data
+ '(("\e$B$$$-\e(B" "\e$B9T\e(B")
+ ("\e$B$,$+$j\e(B" "\e$B78\e(B")
+ ("\e$B$,$/\e(B" "\e$B3X\e(B")
+ ("\e$B$,$o\e(B" "\e$B@n\e(B")
+ ("\e$B$7$c\e(B" "\e$B<R\e(B")
+ ("\e$B$7$e$&\e(B" "\e$B=8\e(B")
+ ("\e$B$7$g$&\e(B" "\e$B>^\e(B" "\e$B>k\e(B")
+ ("\e$B$8$g$&\e(B" "\e$B>k\e(B")
+ ("\e$B$;$s\e(B" "\e$B@~\e(B")
+ ("\e$B$@$1\e(B" "\e$B3Y\e(B")
+ ("\e$B$A$c$/\e(B" "\e$BCe\e(B")
+ ("\e$B$F$s\e(B" "\e$BE9\e(B")
+ ("\e$B$H$&$2\e(B" "\e$BF=\e(B")
+ ("\e$B$I$*$j\e(B" "\e$BDL$j\e(B")
+ ("\e$B$d$^\e(B" "\e$B;3\e(B")
+ ("\e$B$P$7\e(B" "\e$B66\e(B")
+ ("\e$B$O$D\e(B" "\e$BH/\e(B")
+ ("\e$B$b$/\e(B" "\e$BL\\e(B")
+ ("\e$B$f$-\e(B" "\e$B9T\e(B")))
+
+(defun skkdic-convert-postfix (skkbuf buf)
+ (message "Processing POSTFIX entries ...")
+ (goto-char (point-min))
+ (save-excursion
+ (set-buffer buf)
+ (insert ";; Setting postfix entries.\n"
+ "(skkdic-set-postfix\n"))
+
+ ;; Initialize SKKDIC-POSTFIX-LIST by predefined data
+ ;; SKKDIC-POSTFIX-DATA.
+ (save-excursion
+ (set-buffer buf)
+ (let ((l skkdic-postfix-data)
+ kana candidates entry)
+ (while l
+ (setq kana (car (car l)) candidates (cdr (car l)))
+ (insert "\"" kana)
+ (while candidates
+ (insert " " (car candidates))
+ (setq entry (lookup-nested-alist (car candidates)
+ skkdic-postfix-list nil nil t))
+ (if (consp (car entry))
+ (setcar entry (cons kana (car entry)))
+ (set-nested-alist (car candidates) (list kana)
+ skkdic-postfix-list))
+ (setq candidates (cdr candidates)))
+ (insert "\"\n")
+ (setq l (cdr l)))))
+
+ ;; Search postfix entries.
+ (while (re-search-forward "^[#<>?]\\(\\cH+\\) " nil t)
+ (let ((kana (match-string 1))
+ str candidates)
+ (while (looking-at "/[#0-9 ]*\\([^/\n]*\\)/")
+ (setq str (match-string 1))
+ (if (not (member str candidates))
+ (setq candidates (cons str candidates)))
+ (goto-char (match-end 1)))
+ (save-excursion
+ (set-buffer buf)
+ (insert "\"" kana)
+ (while candidates
+ (insert " " (car candidates))
+ (let ((entry (lookup-nested-alist (car candidates)
+ skkdic-postfix-list nil nil t)))
+ (if (consp (car entry))
+ (if (not (member kana (car entry)))
+ (setcar entry (cons kana (car entry))))
+ (set-nested-alist (car candidates) (list kana)
+ skkdic-postfix-list)))
+ (setq candidates (cdr candidates)))
+ (insert "\"\n"))))
+ (save-excursion
+ (set-buffer buf)
+ (insert ")\n\n")))
+
+(defconst skkdic-prefix-list '(skkdic-prefix-list))
+
+(defun skkdic-convert-prefix (skkbuf buf)
+ (message "Processing PREFIX entries ...")
+ (goto-char (point-min))
+ (save-excursion
+ (set-buffer buf)
+ (insert ";; Setting prefix entries.\n"
+ "(skkdic-set-prefix\n"))
+ (save-excursion
+ (while (re-search-forward "^\\(\\cH+\\)[<>?] " nil t)
+ (let ((kana (match-string 1))
+ str candidates)
+ (while (looking-at "/\\([^/\n]+\\)/")
+ (setq str (match-string 1))
+ (if (not (member str candidates))
+ (setq candidates (cons str candidates)))
+ (goto-char (match-end 1)))
+ (save-excursion
+ (set-buffer buf)
+ (insert "\"" kana)
+ (while candidates
+ (insert " " (car candidates))
+ (set-nested-alist (car candidates) kana skkdic-prefix-list)
+ (setq candidates (cdr candidates)))
+ (insert "\"\n")))))
+ (save-excursion
+ (set-buffer buf)
+ (insert ")\n\n")))
+
+;; FROM and TO point the head and tail of "/J../J../.../".
+(defun skkdic-get-candidate-list (from to)
+ (let (candidates)
+ (goto-char from)
+ (while (re-search-forward "/\\cj+" to t)
+ (setq candidates (cons (buffer-substring (1+ (match-beginning 0))
+ (match-end 0))
+ candidates)))
+ candidates))
+
+;; Return entry for STR from nested alist ALIST.
+(defsubst skkdic-get-entry (str alist)
+ (car (lookup-nested-alist str alist nil nil t)))
+
+
+(defconst skkdic-word-list '(skkdic-word-list))
+
+;; Return t if substring of STR (between FROM and TO) can be broken up
+;; to chunks all of which can be derived from another entry in SKK
+;; dictionary. SKKBUF is the buffer where the original SKK dictionary
+;; is visited, KANA is the current entry for STR. FIRST is t iff this
+;; is called at top level.
+
+(defun skkdic-breakup-string (skkbuf kana str from to &optional first)
+ (let ((len (- to from)))
+ (or (and (>= len (* skkdic-jbytes 2))
+ (let ((min-idx (+ from (* skkdic-jbytes 2)))
+ (idx (if first (- to skkdic-jbytes) to))
+ (found nil))
+ (while (and (not found) (>= idx min-idx))
+ (let ((kana2-list (skkdic-get-entry
+ (substring str from idx)
+ skkdic-word-list)))
+ (if (or (and (consp kana2-list)
+ (let ((kana-len (length kana))
+ kana2)
+ (catch 'skkdic-tag
+ (while kana2-list
+ (setq kana2 (car kana2-list))
+ (if (string-match kana2 kana)
+ (throw 'skkdic-tag t))
+ (setq kana2-list (cdr kana2-list)))))
+ (or (= idx to)
+ (skkdic-breakup-string skkbuf kana str
+ idx to)))
+ (and (stringp kana2-list)
+ (string-match kana2-list kana)))
+ (setq found t)
+ (setq idx (- idx skkdic-jbytes)))))
+ found))
+ (and first
+ (> len (* skkdic-jbytes 2))
+ (let ((kana2 (skkdic-get-entry
+ (substring str from (+ from skkdic-jbytes))
+ skkdic-prefix-list)))
+ (and (stringp kana2)
+ (eq (string-match kana2 kana) 0)))
+ (skkdic-breakup-string skkbuf kana str (+ from skkdic-jbytes) to))
+ (and (not first)
+ (>= len skkdic-jbytes)
+ (let ((kana2-list (skkdic-get-entry
+ (substring str from to)
+ skkdic-postfix-list)))
+ (and (consp kana2-list)
+ (let (kana2)
+ (catch 'skkdic-tag
+ (while kana2-list
+ (setq kana2 (car kana2-list))
+ (if (string= kana2
+ (substring kana (- (length kana2))))
+ (throw 'skkdic-tag t))
+ (setq kana2-list (cdr kana2-list)))))))))))
+
+;; Return list of candidates which excludes some from CANDIDATES.
+;; Excluded candidates can be derived from another entry.
+
+(defun skkdic-reduced-candidates (skkbuf kana candidates)
+ (let (elt l)
+ (while candidates
+ (setq elt (car candidates))
+ (if (or (= (length elt) skkdic-jbytes)
+ (and (string-match "^\\cj" elt)
+ (not (skkdic-breakup-string skkbuf kana elt 0 (length elt)
+ 'first))))
+ (setq l (cons elt l)))
+ (setq candidates (cdr candidates)))
+ (nreverse l)))
+
+(defconst skkdic-okuri-nasi-entries (list nil))
+(defconst skkdic-okuri-nasi-entries-count 0)
+
+(defun skkdic-collect-okuri-nasi ()
+ (message "Collecting OKURI-NASI entries ...")
+ (save-excursion
+ (let ((prev-ratio 0)
+ ratio)
+ (while (re-search-forward "^\\(\\cH+\\) \\(/\\cj.*\\)/$" nil t)
+ (let ((kana (match-string 1))
+ (candidates (skkdic-get-candidate-list (match-beginning 2)
+ (match-end 2))))
+ (setq skkdic-okuri-nasi-entries
+ (cons (cons kana candidates) skkdic-okuri-nasi-entries)
+ skkdic-okuri-nasi-entries-count
+ (1+ skkdic-okuri-nasi-entries-count))
+ (setq ratio (floor (/ (* (point) 100.0) (point-max))))
+ (if (/= ratio prev-ratio)
+ (progn
+ (message "collected %2d%% %s ..." ratio kana)
+ (setq prev-ratio ratio)))
+ (while candidates
+ (let ((entry (lookup-nested-alist (car candidates)
+ skkdic-word-list nil nil t)))
+ (if (consp (car entry))
+ (setcar entry (cons kana (car entry)))
+ (set-nested-alist (car candidates) (list kana)
+ skkdic-word-list)))
+ (setq candidates (cdr candidates))))))))
+
+(defun skkdic-convert-okuri-nasi (skkbuf buf)
+ (message "Processing OKURI-NASI entries ...")
+ (save-excursion
+ (set-buffer buf)
+ (insert ";; Setting okuri-nasi entries.\n"
+ "(skkdic-set-okuri-nasi\n")
+ (let ((l (nreverse skkdic-okuri-nasi-entries))
+ (count 0)
+ (prev-ratio 0)
+ ratio)
+ (while l
+ (let ((kana (car (car l)))
+ (candidates (cdr (car l))))
+ (setq ratio (/ (* count 1000) skkdic-okuri-nasi-entries-count)
+ count (1+ count))
+ (if (/= prev-ratio (/ ratio 10))
+ (progn
+ (message "processed %2d%% %s ..." (/ ratio 10) kana)
+ (setq prev-ratio (/ ratio 10))))
+ (if (setq candidates
+ (skkdic-reduced-candidates skkbuf kana candidates))
+ (progn
+ (insert "\"" kana)
+ (while candidates
+ (insert " " (car candidates))
+ (setq candidates (cdr candidates)))
+ (insert "\"\n"))))
+ (setq l (cdr l))))
+ (insert ")\n\n")))
+
+(defun skkdic-convert (filename &optional dirname)
+ "Convert SKK dictionary of FILENAME into the file \"skkdic.el\".
+Optional argument DIRNAME if specified is the directory name under which
+the generated \"skkdic.el\" is saved."
+ (interactive "FSKK dictionary file: ")
+ (message "Reading file \"%s\" ..." filename)
+ (let ((skkbuf(find-file-noselect (expand-file-name filename)))
+ (buf (get-buffer-create "*skkdic-work*")))
+ (save-excursion
+ ;; Setup and generate the header part of working buffer.
+ (set-buffer buf)
+ (erase-buffer)
+ (buffer-disable-undo)
+ (insert ";; skkdic.el -- dictionary for Japanese input method\n"
+ ";;\tGenerated by the command `skkdic-convert'\n"
+ ";;\tDate: " (current-time-string) "\n"
+ ";;\tOriginal SKK dictionary file: "
+ (file-name-nondirectory filename)
+ "\n\n"
+ ";;; Comment:\n\n"
+ ";; Do byte-compile this file again after any modification.\n\n"
+ ";;; Start of the header of the original TIT dictionary.\n\n")
+ (set-buffer skkbuf)
+ (widen)
+ (goto-char 1)
+ (let (pos)
+ (search-forward ";; okuri-ari")
+ (forward-line 1)
+ (setq pos (point))
+ (set-buffer buf)
+ (insert-buffer-substring skkbuf 1 pos))
+ (insert "\n"
+ ";;; Code:\n\n")
+
+ ;; Generate the body part of working buffer.
+ (set-buffer skkbuf)
+ (let ((from (point))
+ to)
+ ;; Convert okuri-ari entries.
+ (search-forward ";; okuri-nasi")
+ (beginning-of-line)
+ (setq to (point))
+ (narrow-to-region from to)
+ (skkdic-convert-okuri-ari skkbuf buf)
+ (widen)
+
+ ;; Convert okuri-nasi postfix entries.
+ (goto-char to)
+ (forward-line 1)
+ (setq from (point))
+ (re-search-forward "^\\cH")
+ (setq to (match-beginning 0))
+ (narrow-to-region from to)
+ (skkdic-convert-postfix skkbuf buf)
+ (widen)
+
+ ;; Convert okuri-nasi prefix entries.
+ (goto-char to)
+ (skkdic-convert-prefix skkbuf buf)
+
+ ;;
+ (skkdic-collect-okuri-nasi)
+
+ ;; Convert okuri-nasi general entries.
+ (skkdic-convert-okuri-nasi skkbuf buf)
+
+ ;; Postfix
+ (save-excursion
+ (set-buffer buf)
+ (goto-char (point-max))
+ (insert ";;\n(provide 'skkdic)\n\n;; skkdic.el ends here\n")))
+
+ ;; Save the working buffer.
+ (set-buffer buf)
+ (set-visited-file-name (expand-file-name skkdic-filename dirname) t)
+ (set-buffer-file-coding-system 'coding-system-iso-2022-7-short)
+ (save-buffer 0))
+ (kill-buffer skkbuf)
+ (switch-to-buffer buf)))
+
+(defun batch-skkdic-convert ()
+ "Run `skkdic-convert' on the files remaining on the command line.
+Use this from the command line, with `-batch';
+it won't work in an interactive Emacs.
+For example, invoke:
+ % emacs -batch -l skkconv -f batch-skkdic-convert SKK-JISYO.L
+to generate \"skkdic.el\" from SKK dictionary file \"SKK-JISYO.L\".
+To get complete usage, invoke:
+ % emacs -batch -l skkconv -f batch-skkdic-convert -h"
+ (defvar command-line-args-left) ; Avoid compiler warning.
+ (if (not noninteractive)
+ (error "`batch-skkdic-convert' should be used only with -batch"))
+ (if (string= (car command-line-args-left) "-h")
+ (progn
+ (message "To convert SKK-JISYO.L into skkdic.el:")
+ (message " %% emacs -batch -l skkdic-conv -f batch-skkdic-convert SKK-JISYO.L")
+ (message "To convert SKK-JISYO.L into DIR/skkdic.el:")
+ (message " %% emacs -batch -l skkdic-conv -f batch-skkdic-convert -dir DIR SKK-JISYO.L"))
+ (let (targetdir filename)
+ (if (string= (car command-line-args-left) "-dir")
+ (progn
+ (setq command-line-args-left (cdr command-line-args-left))
+ (setq targetdir (expand-file-name (car command-line-args-left)))
+ (setq command-line-args-left (cdr command-line-args-left))))
+ (setq filename (expand-file-name (car command-line-args-left)))
+ (message "Converting %s to skkdic.el ..." filename)
+ (message "It takes around 10 minutes even on Sun SS20.")
+ (skkdic-convert filename targetdir)
+ (message "Do byte-compile the created file by:")
+ (message " %% emacs -batch -l skkdic-cnv -f batch-byte-compile skkdic.el")
+ (message " ^^^^^^^^^^^^^ -- Don't forget this option!")
+ ))
+ (kill-emacs 0))
+
+
+;; The following macros are expanded at byte-compiling time so that
+;; compiled code can be loaded quickly.
+
+(defun skkdic-get-kana-compact-codes (kana)
+ (let* ((len (length kana))
+ (vec (make-vector (/ (+ len (1- skkdic-jbytes)) skkdic-jbytes) 0))
+ (i 0)
+ ch)
+ (while (< i len)
+ (setq ch (sref kana i))
+ (aset vec (/ i 3)
+ (if (< ch 128) ; CH is an ASCII letter for OKURIGANA,
+ (- ch) ; represented by a negative code.
+ (if (= ch ?\e$B!<\e(B) ; `\e$B!<\e(B' is represented by 0.
+ 0
+ (- (nth 2 (split-char ch)) 32))))
+ (setq i (+ i 3)))
+ vec))
+
+(defun skkdic-extract-conversion-data (entry)
+ (string-match "^\\cH+[a-z]* " entry)
+ (let ((kana (substring entry (match-beginning 0) (1- (match-end 0))))
+ (i (match-end 0))
+ candidates)
+ (while (string-match "[^ ]+" entry i)
+ (setq candidates (cons (match-string 0 entry) candidates))
+ (setq i (match-end 0)))
+ (cons (skkdic-get-kana-compact-codes kana) candidates)))
+
+(defmacro skkdic-set-okuri-ari (&rest entries)
+ `(defconst skkdic-okuri-ari
+ ',(let ((l entries)
+ (map '(skkdic-okuri-ari))
+ entry)
+ (while l
+ (setq entry (skkdic-extract-conversion-data (car l)))
+ (set-nested-alist (car entry) (cdr entry) map)
+ (setq l (cdr l)))
+ map)))
+
+(defmacro skkdic-set-postfix (&rest entries)
+ `(defconst skkdic-postfix
+ ',(let ((l entries)
+ (map '(nil))
+ (longest 1)
+ len entry)
+ (while l
+ (setq entry (skkdic-extract-conversion-data (car l)))
+ (setq len (length (car entry)))
+ (if (> len longest)
+ (setq longest len))
+ (let ((entry2 (lookup-nested-alist (car entry) map nil nil t)))
+ (if (consp (car entry2))
+ (let ((conversions (cdr entry)))
+ (while conversions
+ (if (not (member (car conversions) (car entry2)))
+ (setcar entry2 (cons (car conversions) (car entry2))))
+ (setq conversions (cdr conversions))))
+ (set-nested-alist (car entry) (cdr entry) map)))
+ (setq l (cdr l)))
+ (setcar map longest)
+ map)))
+
+(defmacro skkdic-set-prefix (&rest entries)
+ `(defconst skkdic-prefix
+ ',(let ((l entries)
+ (map '(nil))
+ (longest 1)
+ len entry)
+ (while l
+ (setq entry (skkdic-extract-conversion-data (car l)))
+ (setq len (length (car entry)))
+ (if (> len longest)
+ (setq longest len))
+ (let ((entry2 (lookup-nested-alist (car entry) map len nil t)))
+ (if (consp (car entry2))
+ (let ((conversions (cdr entry)))
+ (while conversions
+ (if (not (member (car conversions) (car entry2)))
+ (setcar entry2 (cons (car conversions) (car entry2))))
+ (setq conversions (cdr conversions))))
+ (set-nested-alist (car entry) (cdr entry) map len)))
+ (setq l (cdr l)))
+ (setcar map longest)
+ map)))
+
+(defmacro skkdic-set-okuri-nasi (&rest entries)
+ `(defconst skkdic-okuri-nasi
+ ',(let ((l entries)
+ (map '(skdic-okuri-nasi))
+ (count 0)
+ entry)
+ (while l
+ (setq count (1+ count))
+ (if (= (% count 10) 0)
+ (message (format "%d entries" count)))
+ (setq entry (skkdic-extract-conversion-data (car l)))
+ (set-nested-alist (car entry) (cdr entry) map)
+ (setq l (cdr l)))
+ map)))
+
+;; skkdic-cnv.el ends here
--- /dev/null
+;; skkdic-utl.el -- utility functions for handling skkdic.el
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: mule, multilingual, Japanese, SKK
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; SKK is a free Japanese input method running on Mule created by
+;; Masahiko Sato <masahiko@sato.riec.tohoku.ac.jp>. A dictionary of
+;; SKK can be converted by `skkdic-convert' (skkdic-conv.el) to a file
+;; "skkdic.el" in which the dictionary entries are defined in the
+;; format which can be handled by the following functions.
+
+;;; Code:
+
+(defvar skkdic-okuri-ari nil
+ "OKURI-ARI entries of SKK dictionary.")
+(defvar skkdic-postfix nil
+ "POSTFIX entries of SKK dictionary.")
+(defvar skkdic-prefix nil
+ "PREFIX entries of SKK dictionary.")
+(defvar skkdic-okuri-nasi nil
+ "OKURI-NASI entries of SKK dictionary.")
+
+;; Alist of Okuriganas vs trailing ASCII letters in OKURI-ARI entry.
+(defconst skkdic-okurigana-table
+ '((?\e$B$!\e(B . ?a) (?\e$B$"\e(B . ?a) (?\e$B$#\e(B . ?i) (?\e$B$$\e(B . ?i) (?\e$B$%\e(B . ?u)
+ (?\e$B$&\e(B . ?u) (?\e$B$'\e(B . ?e) (?\e$B$(\e(B . ?e) (?\e$B$)\e(B . ?o) (?\e$B$*\e(B . ?o)
+ (?\e$B$+\e(B . ?k) (?\e$B$,\e(B . ?g) (?\e$B$-\e(B . ?k) (?\e$B$.\e(B . ?g) (?\e$B$/\e(B . ?k)
+ (?\e$B$0\e(B . ?g) (?\e$B$1\e(B . ?k) (?\e$B$2\e(B . ?g) (?\e$B$3\e(B . ?k) (?\e$B$4\e(B . ?g)
+ (?\e$B$5\e(B . ?s) (?\e$B$6\e(B . ?z) (?\e$B$7\e(B . ?s) (?\e$B$8\e(B . ?j) (?\e$B$9\e(B . ?s)
+ (?\e$B$:\e(B . ?z) (?\e$B$;\e(B . ?s) (?\e$B$<\e(B . ?z) (?\e$B$=\e(B . ?s) (?\e$B$>\e(B . ?z)
+ (?\e$B$?\e(B . ?t) (?\e$B$@\e(B . ?d) (?\e$B$A\e(B . ?t) (?\e$B$B\e(B . ?d) (?\e$B$C\e(B . ?t)
+ (?\e$B$D\e(B . ?t) (?\e$B$E\e(B . ?d) (?\e$B$F\e(B . ?t) (?\e$B$G\e(B . ?d) (?\e$B$H\e(B . ?t) (?\e$B$I\e(B . ?d)
+ (?\e$B$J\e(B . ?n) (?\e$B$K\e(B . ?n) (?\e$B$L\e(B . ?n) (?\e$B$M\e(B . ?n) (?\e$B$N\e(B . ?n)
+ (?\e$B$O\e(B . ?h) (?\e$B$P\e(B . ?b) (?\e$B$Q\e(B . ?p) (?\e$B$R\e(B . ?h) (?\e$B$S\e(B . ?b)
+ (?\e$B$T\e(B . ?p) (?\e$B$U\e(B . ?h) (?\e$B$V\e(B . ?b) (?\e$B$W\e(B . ?p) (?\e$B$X\e(B . ?h)
+ (?\e$B$Y\e(B . ?b) (?\e$B$Z\e(B . ?p) (?\e$B$[\e(B . ?h) (?\e$B$\\e(B . ?b) (?\e$B$]\e(B . ?p)
+ (?\e$B$^\e(B . ?m) (?\e$B$_\e(B . ?m) (?\e$B$`\e(B . ?m) (?\e$B$a\e(B . ?m) (?\e$B$b\e(B . ?m)
+ (?\e$B$c\e(B . ?y) (?\e$B$d\e(B . ?y) (?\e$B$e\e(B . ?y) (?\e$B$f\e(B . ?y) (?\e$B$g\e(B . ?y) (?\e$B$h\e(B . ?y)
+ (?\e$B$i\e(B . ?r) (?\e$B$j\e(B . ?r) (?\e$B$k\e(B . ?r) (?\e$B$l\e(B . ?r) (?\e$B$m\e(B . ?r)
+ (?\e$B$o\e(B . ?w) (?\e$B$p\e(B . ?w) (?\e$B$q\e(B . ?w) (?\e$B$r\e(B . ?w)
+ (?\e$B$s\e(B . ?n)
+ ))
+
+(defconst skkdic-jbytes
+ (charset-bytes 'japanese-jisx0208))
+
+(defun skkdic-merge-head-and-tail (heads tails postfix)
+ (let ((min-len (* skkdic-jbytes 2))
+ l)
+ (while heads
+ (if (or (not postfix)
+ (>= (length (car heads)) min-len))
+ (let ((tail tails))
+ (while tail
+ (if (or postfix
+ (>= (length (car tail)) min-len))
+ (setq l (cons (concat (car heads) (car tail)) l)))
+ (setq tail (cdr tail)))))
+ (setq heads (cdr heads)))
+ l))
+
+(defconst skkdic-jisx0208-hiragana-block (nth 1 (split-char ?\e$B$"\e(B)))
+
+(defun skkdic-lookup-key (seq len &optional postfix)
+ "Return a list of conversion string for sequence SEQ of length LEN.
+
+SEQ is a vector of Kana characters to be converted by SKK dictionary.
+If LEN is shorter than the length of KEYSEQ, the first LEN keys in SEQ
+are took into account.
+
+Postfixes are handled only if the optional argument POSTFIX is non-nil."
+ (or skkdic-okuri-nasi
+ (condition-case err
+ (load-library "skk/skkdic")
+ (error (ding)
+ (with-output-to-temp-buffer "*Help*"
+ (princ "The library `skkdic' can't be loaded.
+
+The most common case is that you have not yet installed the library
+included in LEIM (Libraries of Emacs Input Method) which is
+distributed separately from Emacs.
+
+LEIM is available from the same ftp directory as Emacs."))
+ (signal (car err) (cdr err)))))
+
+ (let ((vec (make-vector len 0))
+ (i 0)
+ entry)
+ ;; At first, generate vector VEC from SEQ for looking up SKK
+ ;; alists. Nth element in VEC corresponds to Nth element in SEQ.
+ ;; The values are decided as follows.
+ ;; If SEQ[N] is `\e$B!<\e(B', VEC[N] is 0,
+ ;; Else if SEQ[N] is a Hiragana character, VEC[N] is:
+ ;; ((The 2nd position code o SEQ[N]) - 32),
+ ;; ELse VEC[N] is 128.
+ (while (< i len)
+ (let ((ch (aref seq i))
+ elts)
+ (if (= ch ?\e$B!<\e(B)
+ (aset vec i 0)
+ (setq elts (split-char ch))
+ (if (and (eq (car elts) 'japanese-jisx0208)
+ (= (nth 1 elts) skkdic-jisx0208-hiragana-block))
+ (aset vec i (- (nth 2 elts) 32))
+ (aset vec i 128))))
+ (setq i (1+ i)))
+
+ ;; Search OKURI-NASI entries.
+ (setq entry (lookup-nested-alist vec skkdic-okuri-nasi len 0 t))
+ (if (consp (car entry))
+ (setq entry (copy-sequence (car entry)))
+ (setq entry nil))
+
+ (if postfix
+ ;; Search OKURI-NASI entries with postfixes.
+ (let ((break (max (- len (car skkdic-postfix)) 1))
+ entry-head entry-postfix entry2)
+ (while (< break len)
+ (if (and (setq entry-head
+ (lookup-nested-alist vec skkdic-okuri-nasi
+ break 0 t))
+ (consp (car entry-head))
+ (setq entry-postfix
+ (lookup-nested-alist vec skkdic-postfix
+ len break t))
+ (consp (car entry-postfix))
+ (setq entry2 (skkdic-merge-head-and-tail
+ (car entry-head) (car entry-postfix) t)))
+ (if entry
+ (nconc entry entry2)
+ (setq entry entry2)))
+ (setq break (1+ break)))))
+
+ ;; Search OKURI-NASI entries with prefixes.
+ (let ((break (min (car skkdic-prefix) (- len 2)))
+ entry-prefix entry-tail entry2)
+ (while (> break 0)
+ (if (and (setq entry-prefix
+ (lookup-nested-alist vec skkdic-prefix break 0 t))
+ (consp (car entry-prefix))
+ (setq entry-tail
+ (lookup-nested-alist vec skkdic-okuri-nasi len break t))
+ (consp (car entry-tail))
+ (setq entry2 (skkdic-merge-head-and-tail
+ (car entry-prefix) (car entry-tail) nil)))
+ (if entry
+ (nconc entry entry2)
+ (setq entry entry2)))
+ (setq break (1- break))))
+
+ ;; Search OKURI-ARI entries.
+ (let ((okurigana (assq (aref seq (1- len)) skkdic-okurigana-table))
+ orig-element entry2)
+ (if okurigana
+ (progn
+ (setq orig-element (aref vec (1- len)))
+ (aset vec (1- len) (- (cdr okurigana)))
+ (if (and (setq entry2 (lookup-nested-alist vec skkdic-okuri-ari
+ len 0 t))
+ (consp (car entry2)))
+ (progn
+ (setq entry2 (copy-sequence (car entry2)))
+ (let ((l entry2)
+ (okuri (char-to-string (aref seq (1- len)))))
+ (while l
+ (setcar l (concat (car l) okuri))
+ (setq l (cdr l)))
+ (if entry
+ (nconc entry entry2)
+ (setq entry entry2)))))
+ (aset vec (1- len) orig-element))))
+
+ entry))
+
+;;
+(provide 'skkdic-utl)
+
+;; skkdic-utl.el ends here
--- /dev/null
+;;; titdic-cnv.el --- convert TIT dictionary to Quail package
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: Quail, TIT, cxterm
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Comments:
+
+;; Convert TIT format dictionary (of cxterm) to quail-package.
+;;
+;; Usage (within Emacs):
+;; M-x titdic-convert<CR>TIT-FILE-NAME<CR>
+;; Usage (from shell):
+;; % emacs -batch -l titdic-convert -f batch-titdic-convert\
+;; [-dir DIR] [DIR | FILE] ...
+;;
+;; When you run titdic-convert within Emacs, you have a chance to
+;; modify arguments of `quail-define-package' before saving the
+;; converted file. For instance, you are likely to modify TITLE,
+;; DOCSTRING, and KEY-BINDINGS.
+
+;; TIT dictionary file (*.tit) is a line-oriented text (English,
+;; Chinese, Japanese, and Korean) file. The whole file contains of
+;; two parts, the definition part (`header' here after) followed by
+;; the dictionary part (`body' here after). All lines begin with
+;; leading '#' are ignored.
+;;
+;; Each line in the header part has two fields, KEY and VALUE. These
+;; fields are separated by one or more white characters.
+;;
+;; Each line in the body part has two fields, KEYSEQ and TRANSLATIONS.
+;; These fields are separated by one or more white characters.
+;;
+;; See the manual page of `tit2cit' of cxterm distribution for more
+;; detail.
+
+;;; Code:
+
+(require 'quail)
+
+;; List of values of key "ENCODE:" and the corresponding Emacs'
+;; coding-system and language environment name.
+(defvar tit-encode-list
+ '(("GB" coding-system-euc-china "Chinese-GB")
+ ("BIG5" coding-system-big5 "Chinese-BIG5")
+ ("JIS" coding-system-euc-japan "Japanese")
+ ("KS" coding-system-euc-korea "Korean")))
+
+;; Return a value of the key in the current line.
+(defsubst tit-read-key-value ()
+ (if (looking-at "[^ \t\n]+")
+ (car (read-from-string (concat "\"" (match-string 0) "\"")))))
+
+;; Return an appropriate quail-package filename from FILENAME (TIT
+;; dictionary filename). For instance, ".../ZOZY.tit" -> "zozy.el".
+(defun tit-make-quail-package-name (filename &optional dirname)
+ (expand-file-name
+ (concat (downcase (file-name-nondirectory (substring filename 0 -4))) ".el")
+ dirname))
+
+;; This value is t if we are processing phrase dictionary.
+(defvar tit-phrase nil)
+(defvar tit-encode nil)
+(defvar tit-default-encode "GB")
+
+;; Generate elements of KEY-BINDINGS arg for `quail-define-package' so
+;; that each characters in KEYS invokes FUNCTION-SYMBOL.
+(defun tit-generate-key-bindings (keys function-symbol)
+ (let ((len (length keys))
+ (i 0)
+ key)
+ (while (< i len)
+ (setq key (aref keys i))
+ (indent-to 3)
+ (if (< key ?\ )
+ (if (eq (lookup-key quail-translation-keymap (char-to-string key))
+ 'quail-execute-non-quail-command)
+ (insert (format "(\"\\C-%c\" . %s)\n"
+ (+ key ?@) function-symbol)))
+ (if (< key 127)
+ (insert (format "(\"%c\" . %s)\n" key function-symbol))
+ (insert (format "(\"\\C-?\" . %s)\n" function-symbol))))
+ (setq i (1+ i)))))
+
+;; Analyze header part of TIT dictionary and generate an appropriate
+;; `quail-define-package' function call.
+(defun tit-process-header (filename)
+ (message "Processing header part...")
+ (goto-char (point-min))
+
+ (let (;; TIT keywords and the corresponding default values.
+ (tit-multichoice t)
+ (tit-prompt "")
+ (tit-comments nil)
+ (tit-backspace "\010\177")
+ (tit-deleteall "\015\025")
+ (tit-moveright ".>")
+ (tit-moveleft ",<")
+ (tit-keyprompt nil))
+ ;; At first, collect information from the header.
+ (while (not (eobp))
+ (insert ";; ")
+ (let ((ch (following-char)))
+ (cond ((= ch ?C) ; COMMENT
+ (cond ((looking-at "COMMENT")
+ (let ((pos (match-end 0)))
+ (end-of-line)
+ (while (re-search-backward "[\"\\]" pos t)
+ (insert "\\")
+ (forward-char -1))
+ (end-of-line)
+ (setq tit-comments (cons (buffer-substring pos (point))
+ tit-comments))))))
+ ((= ch ?M) ; MULTICHOICE, MOVERIGHT, MOVELEFT
+ (cond ((looking-at "MULTICHOICE:[ \t]*")
+ (goto-char (match-end 0))
+ (setq tit-multichoice (looking-at "YES")))
+ ((looking-at "MOVERIGHT:[ \t]*")
+ (goto-char (match-end 0))
+ (setq tit-moveright (tit-read-key-value)))
+ ((looking-at "MOVELEFT:[ \t]*")
+ (goto-char (match-end 0))
+ (setq tit-moveleft (tit-read-key-value)))))
+ ((= ch ?P) ; PROMPT
+ (cond ((looking-at "PROMPT:[ \t]*")
+ (goto-char (match-end 0))
+ (setq tit-prompt (tit-read-key-value)))))
+ ((= ch ?B) ; BACKSPACE, BEGINDICTIONARY,
+ ; BEGINPHRASE
+ (cond ((looking-at "BACKSPACE:[ \t]*")
+ (goto-char (match-end 0))
+ (setq tit-backspace (tit-read-key-value)))
+ ((looking-at "BEGINDICTIONARY")
+ (setq tit-phrase nil))
+ ((looking-at "BEGINPHRASE")
+ (setq tit-phrase t))))
+ ((= ch ?K) ; KEYPROMPT
+ (cond ((looking-at "KEYPROMPT(\\(.*\\)):[ \t]*")
+ (let ((key-char (match-string 1)))
+ (goto-char (match-end 0))
+ (setq tit-keyprompt
+ (cons (cons key-char (tit-read-key-value))
+ tit-keyprompt))))))))
+ (forward-line 1))
+
+ ;; Then, generate header part of the Quail package.
+ (goto-char (point-min))
+ (insert ";; Quail package `"
+ (substring (file-name-nondirectory buffer-file-name) 0 -3)
+ "' generated by the command `titdic-convert'\n"
+ ";;\tDate: " (current-time-string) "\n"
+ ";;\tOriginal TIT dictionary file: "
+ (file-name-nondirectory filename)
+ "\n\n"
+ ";;; Comment:\n\n"
+ ";; Do byte-compile this file again after any modification.\n\n"
+ ";;; Start of the header of original TIT dictionary.\n\n")
+
+ (goto-char (point-max))
+ (insert "\n"
+ ";;; End of the header of original TIT dictionary.\n\n"
+ ";;; Code:\n\n"
+ "(require 'quail)\n\n")
+
+ (insert "(quail-define-package ")
+ ;; Args NAME, LANGUAGE, TITLE
+ (insert
+ "\""
+ (concat "quail-"
+ (substring (file-name-nondirectory buffer-file-name) 0 -3))
+ "\" \"" (nth 2 (assoc tit-encode tit-encode-list))
+ "\" \""
+ (if (string-match "[:\e$A!K\e$(0!(!J\e(B]+\\([^:\e$A!K\e$(0!(!K\e(B]+\\)" tit-prompt)
+ (substring tit-prompt (match-beginning 1) (match-end 1))
+ tit-prompt)
+ "\"\n")
+
+ ;; Arg GUIDANCE
+ (if tit-keyprompt
+ (progn
+ (insert " '(")
+ (while tit-keyprompt
+ (indent-to 3)
+ (insert (format "(%d . \"%s\")\n"
+ (string-to-char (car (car tit-keyprompt)))
+ (cdr (car tit-keyprompt))))
+ (setq tit-keyprompt (cdr tit-keyprompt)))
+ (forward-char -1)
+ (insert ")")
+ (forward-char 1))
+ (insert " t\n"))
+
+ ;; Arg DOCSTRING
+ (insert "\"" tit-prompt "\n")
+ (let ((l (nreverse tit-comments)))
+ (while l
+ (insert (format "%s\n" (car l)))
+ (setq l (cdr l))))
+ (insert "\"\n")
+
+ ;; Arg KEY-BINDINGS
+ (insert " '(")
+ (tit-generate-key-bindings tit-backspace 'quail-delete-last-char)
+ (tit-generate-key-bindings tit-deleteall 'quail-abort-translation)
+ (tit-generate-key-bindings tit-moveright 'quail-next-translation)
+ (tit-generate-key-bindings tit-moveleft 'quail-prev-translation)
+ (forward-char -1)
+ (insert ")")
+ (forward-char 1)
+
+ ;; Args FORGET-TRANSLATION, DETERMINISTIC, KBD-TRANSLATE, SHOW-LAYOUT.
+ ;; The remaining args are all nil.
+ (insert " nil"
+ (if tit-multichoice " nil" " t")
+ (if tit-keyprompt " t t)\n\n" " nil nil)\n\n")))
+
+ ;; Return the position of end of the header.
+ (point-max))
+
+;; Convert body part of TIT dictionary into `quail-define-rules'
+;; function call.
+(defun tit-process-body ()
+ (message "Formatting translation rules...")
+ (let ((enable-multibyte-characters nil)
+ (keyseq "\000")
+ pos)
+ (insert "(quail-define-rules\n")
+ (while (null (eobp))
+ (if (or (= (following-char) ?#) (= (following-char) ?\n))
+ (insert ";; ")
+ (insert "(\"")
+ (setq pos (point))
+ (skip-chars-forward "^ \t")
+ (setq keyseq
+ (concat (regexp-quote (buffer-substring pos (point))) "[ \t]+"))
+ (save-excursion
+ (while (re-search-backward "[\\\"]" pos t)
+ (insert "\\")
+ (forward-char -1)))
+ (insert "\"")
+ (skip-chars-forward " \t")
+
+ ;; Now point is at the start of translations. Remember it in
+ ;; POS and combine lines of the same key sequence while
+ ;; deleting trailing white spaces and comments (start with
+ ;; '#'). POS doesn't has to be a marker because we never
+ ;; modify region before POS.
+ (setq pos (point))
+ (if (looking-at "[^ \t]*\\([ \t]*#.*\\)")
+ (delete-region (match-beginning 1) (match-end 1)))
+ (while (and (= (forward-line 1) 0)
+ (looking-at keyseq))
+ (let ((p (match-end 0)))
+ (skip-chars-backward " \t\n")
+ (delete-region (point) p)
+ (if tit-phrase (insert " "))
+ (if (looking-at "[^ \t]*\\([ \t]*#.*\\)")
+ (delete-region (match-beginning 1) (match-end 1)))
+ ))
+
+ ;; Modify the current line to meet the syntax of Quail package.
+ (goto-char pos)
+ (if tit-phrase
+ (progn
+ ;; PHRASE1 PHRASE2 ... => ["PHRASE1" "PHRASE2" ...]
+ (insert "[\"")
+ (skip-chars-forward "^ \t\n")
+ (while (not (eolp))
+ (insert "\"")
+ (forward-char 1)
+ (insert "\"")
+ (skip-chars-forward "^ \t\n"))
+ (insert "\"])"))
+ ;; TRANSLATIONS => "TRANSLATIONS"
+ (insert "\"")
+ (end-of-line)
+ (insert "\")")))
+ (forward-line 1))
+ (insert ")\n")))
+
+;;;###autoload
+(defun titdic-convert (filename &optional dirname)
+ "Convert a TIT dictionary of FILENAME into a Quail package.
+Optional argument DIRNAME if specified is the directory name under which
+the generated Quail package is saved."
+ (interactive "FTIT dictionary file: ")
+ (let ((buf (get-buffer-create "*tit-work*")))
+ (save-excursion
+ ;; Setup the buffer.
+ (set-buffer buf)
+ (erase-buffer)
+ (let ((coding-system-for-read 'no-conversion))
+ (insert-file-contents (expand-file-name filename)))
+ (set-visited-file-name (tit-make-quail-package-name filename dirname) t)
+ (set-buffer-file-coding-system 'coding-system-iso-2022-7)
+
+ ;; Decode the buffer contents from the encoding specified by a
+ ;; value of the key "ENCODE:".
+ (let (coding-system)
+ (save-excursion
+ (if (search-forward "\nBEGIN" nil t)
+ (let ((limit (point))
+ slot)
+ (goto-char 1)
+ (if (re-search-forward "^ENCODE:[ \t]*" limit t)
+ (progn
+ (goto-char (match-end 0))
+ (setq tit-encode (tit-read-key-value)))
+ (setq tit-encode tit-default-encode))
+ (setq slot (assoc tit-encode tit-encode-list))
+ (if slot
+ (setq coding-system (nth 1 slot))
+ (error "Invalid ENCODE: value in TIT dictionary")))
+ (error "TIT dictionary doesn't have body part")))
+ (message "Decoding %s..." coding-system)
+ (goto-char 1)
+ (decode-coding-region 1 (point-max) coding-system))
+
+ ;; Set point the starting position of the body part.
+ (goto-char 1)
+ (if (search-forward "\nBEGIN" nil t)
+ (forward-line 1)
+ (error "TIT dictionary can't be decoded correctly"))
+
+ ;; Now process the header and body parts.
+ (goto-char
+ (save-excursion
+ (save-restriction
+ (narrow-to-region 1 (point))
+ (tit-process-header filename))))
+ (tit-process-body))
+
+ (if noninteractive
+ ;; Save the Quail package file.
+ (save-excursion
+ (set-buffer buf)
+ (save-buffer 0))
+ ;; Show the Quail package just generated.
+ (switch-to-buffer buf)
+ (goto-char 1)
+ (message "Save this buffer after you make any modification"))))
+
+;;;###autoload
+(defun batch-titdic-convert ()
+ "Run `titdic-convert' on the files remaining on the command line.
+Use this from the command line, with `-batch';
+it won't work in an interactive Emacs.
+For example, invoke \"emacs -batch -f batch-titdic-convert XXX.tit\" to
+ generate Quail package file \"xxx.el\" from TIT dictionary file \"XXX.tit\".
+To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
+ (defvar command-line-args-left) ; Avoid compiler warning.
+ (if (not noninteractive)
+ (error "`batch-titdic-convert' should be used only with -batch"))
+ (if (string= (car command-line-args-left) "-h")
+ (progn
+ (message "To convert XXX.tit and YYY.tit into xxx.el and yyy.el:")
+ (message " %% emacs -batch -l titdic-cnv -f batch-titdic-convert XXX.tit YYY.tit")
+ (message "To convert XXX.tit into DIR/xxx.el:")
+ (message " %% emacs -batch -l titdic-cnv -f batch-titdic-convert -dir DIR XXX.tit"))
+ (let (targetdir filename files file)
+ (if (string= (car command-line-args-left) "-dir")
+ (progn
+ (setq command-line-args-left (cdr command-line-args-left))
+ (setq targetdir (car command-line-args-left))
+ (setq command-line-args-left (cdr command-line-args-left))))
+ (while command-line-args-left
+ (setq filename (expand-file-name (car command-line-args-left)))
+ (if (file-directory-p filename)
+ (progn
+ (message "Converting all tit files in the directory %s" filename)
+ (setq files (directory-files filename t "\\.tit$")))
+ (setq files (list filename)))
+ (while files
+ (setq file (expand-file-name (car files)))
+ (if (file-newer-than-file-p
+ file (tit-make-quail-package-name file targetdir))
+ (progn
+ (message "Converting %s to quail-package..." file)
+ (titdic-convert file targetdir)))
+ (setq files (cdr files)))
+ (setq command-line-args-left (cdr command-line-args-left)))
+ (message "Do byte-compile the created files by:")
+ (message " %% emacs -batch -f batch-byte-compile XXX.el")))
+ (kill-emacs 0))
+
+;;; titdic-cnv.el ends here
--- /dev/null
+;; china-util.el -- utilities for Chinese
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: mule, multilingual, Chinese
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Code:
+
+;; Hz/ZW encoding stuffs
+
+;; HZ is an encoding method for Chinese character set GB2312 used
+;; widely in Internet. It is very similar to 7-bit environment of
+;; ISO-2022. The difference is that HZ uses the sequence "~{" and
+;; "~}" for designating GB2312 and ASCII respectively, hence, it
+;; doesn't uses ESC (0x1B) code.
+
+;; ZW is another encoding method for Chinese character set GB2312. It
+;; encodes Chinese characters line by line by starting each line with
+;; the sequence "zW". It also uses only 7-bit as HZ.
+
+;; ISO-2022 escape sequence to designate GB2312.
+(defvar iso2022-gb-designation "\e$A")
+;; HZ escape sequence to designate GB2312.
+(defvar hz-gb-designnation "~{")
+;; ISO-2022 escape sequence to designate ASCII.
+(defvar iso2022-ascii-designation "\e(B")
+;; HZ escape sequence to designate ASCII.
+(defvar hz-ascii-designnation "~}")
+;; Regexp of ZW sequence to start GB2312.
+(defvar zw-start-gb "^zW")
+;; Regexp for start of GB2312 in an encoding mixture of HZ and ZW.
+(defvar hz/zw-start-gb (concat hz-gb-designnation "\\|" zw-start-gb))
+
+(defvar decode-hz-line-continuation nil
+ "Flag to tell if we should care line continuation convention of Hz.")
+
+;;;###autoload
+(defun decode-hz-region (beg end)
+ "Decode HZ/ZW encoded text in the current region.
+Return the length of resulting text."
+ (interactive "r")
+ (save-excursion
+ (save-restriction
+ (narrow-to-region beg end)
+
+ ;; We, at first, convert HZ/ZW to `coding-system-iso-2022-7',
+ ;; then decode it.
+
+ ;; "~\n" -> "\n"
+ (goto-char (point-min))
+ (while (search-forward "~" nil t)
+ (if (= (following-char) ?\n) (delete-char -1))
+ (if (not (eobp)) (forward-char 1)))
+
+ ;; "^zW...\n" -> Chinese GB2312
+ ;; "~{...~}" -> Chinese GB2312
+ (goto-char (point-min))
+ (let ((chinese-found nil))
+ (while (re-search-forward hz/zw-start-gb nil t)
+ (if (= (char-after (match-beginning 0)) ?z)
+ ;; ZW -> coding-system-iso-20227-7
+ (progn
+ (delete-char -2)
+ (insert iso2022-gb-designation)
+ (end-of-line)
+ (insert iso2022-ascii-designation))
+ ;; HZ -> coding-system-iso-20227-7
+ (delete-char -2)
+ (insert iso2022-gb-designation)
+ (let ((pos (save-excursion (end-of-line) (point))))
+ (if (search-forward hz-ascii-designnation pos t)
+ (replace-match iso2022-ascii-designation)
+ (if (not decode-hz-line-continuation)
+ (insert iso2022-ascii-designation)))))
+ (setq chinese-found t))
+ (if (or chinese-found
+ (let ((enable-multibyte-characters nil))
+ ;; Here we check if the text contains EUC (China) codes.
+ ;; If any, we had better decode them also.
+ (goto-char (point-min))
+ (re-search-forward "[\240-\377]" nil t)))
+ (decode-coding-region (point-min) (point-max)
+ 'coding-system-euc-china)))
+
+ ;; "~~" -> "~"
+ (goto-char (point-min))
+ (while (search-forward "~~" nil t) (delete-char -1))
+ (- (point-max) (point-min)))))
+
+;;;###autoload
+(defun decode-hz-buffer ()
+ "Decode HZ/ZW encoded text in the current buffer."
+ (interactive)
+ (decode-hz-region (point-min) (point-max)))
+
+;;;###autoload
+(defun encode-hz-region (beg end)
+ "Encode the text in the current region to HZ.
+Return the length of resulting text."
+ (interactive "r")
+ (save-excursion
+ (save-restriction
+ (narrow-to-region beg end)
+
+ ;; "~" -> "~~"
+ (goto-char (point-min))
+ (while (search-forward "~" nil t) (insert ?~))
+
+ ;; Chinese GB2312 -> "~{...~}"
+ (goto-char (point-min))
+ (if (re-search-forward "\\cc" nil t)
+ (let ((enable-multibyte-characters nil)
+ pos)
+ (goto-char (setq pos (match-beginning 0)))
+ (encode-coding-region pos (point-max) 'coding-system-iso-2022-7)
+ (goto-char pos)
+ (while (search-forward iso2022-gb-designation nil t)
+ (delete-char -3)
+ (insert hz-gb-designnation))
+ (goto-char pos)
+ (while (search-forward iso2022-ascii-designation nil t)
+ (delete-char -3)
+ (insert hz-ascii-designnation))))
+ (- (point-max) (point-min)))))
+
+;;;###autoload
+(defun encode-hz-buffer ()
+ "Encode the text in the current buffer to HZ."
+ (interactive)
+ (encode-hz-region (point-min) (point-max)))
+
+;;
+(provide 'language/china-util)
+
+;;; Local Variables:
+;;; generated-autoload-file: "../loaddefs.el"
+;;; End:
+;;; china-util.el ends here
--- /dev/null
+;;; chinese.el --- Support for Chinese
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: multilingual, Chinese
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; For Chinese, three character sets GB2312, BIG5, and CNS11643 are
+;; supported.
+
+;;; Code:
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Chinese (general)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(make-coding-system
+ 'coding-system-iso-2022-cn 2 ?C
+ "Coding system ISO-2022-CN for Chinese (GB and CNS character sets)."
+ '(ascii
+ (nil chinese-gb2312 chinese-cns11643-1)
+ (nil chinese-cns11643-2)
+ (nil chinese-cns11643-3 chinese-cns11643-4 chinese-cns11643-5
+ chinese-cns11643-6 chinese-cns11643-7)
+ nil ascii-eol ascii-cntl seven locking-shift single-shift))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Chinese GB2312 (simplified)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(make-coding-system
+ 'coding-system-euc-china 2 ?C
+ "Coding-system of Chinese EUC (so called GB Encoding)."
+ '((ascii t) chinese-gb2312 chinese-sisheng nil
+ nil ascii-eol ascii-cntl nil nil single-shift nil))
+
+(make-coding-system
+ 'coding-system-hz 0 ?z
+ "Codins-system of Hz/ZW used for Chinese (GB)."
+ nil)
+(put 'coding-system-hz 'post-read-conversion 'post-read-decode-hz)
+(put 'coding-system-hz 'pre-write-conversion 'pre-write-encode-hz)
+
+(defun post-read-decode-hz (len)
+ (let ((pos (point)))
+ (decode-hz-region pos (+ pos len))))
+
+(defun pre-write-encode-hz (from to)
+ (let ((buf (current-buffer))
+ (work (get-buffer-create " *pre-write-encoding-work*")))
+ (set-buffer work)
+ (widen)
+ (erase-buffer)
+ (insert-buffer-substring buf from to)
+ (encode-hz-region 1 (point-max))
+ nil))
+
+(register-input-method
+ "Chinese-GB" '("quail-ccdospy" quail-use-package "quail/ccdospy"))
+(register-input-method
+ "Chinese-GB" '("quail-ctlau" quail-use-package "quail/ctlau"))
+(register-input-method
+ "Chinese-GB" '("quail-punct" quail-use-package "quail/punct"))
+(register-input-method
+ "Chinese-GB" '("quail-qj" quail-use-package "quail/qj"))
+(register-input-method
+ "Chinese-GB" '("quail-sw" quail-use-package "quail/sw"))
+(register-input-method
+ "Chinese-GB" '("quail-ziranma" quail-use-package "quail/ziranma"))
+(register-input-method
+ "Chinese-GB" '("quail-tonepy" quail-use-package "quail/tonepy"))
+(register-input-method
+ "Chinese-GB" '("quail-py" quail-use-package "quail/py"))
+
+(defun setup-chinese-gb-environment ()
+ (setq primary-language "Chinese-GB")
+
+ (setq coding-category-iso-8-2 'coding-system-euc-china)
+ (setq coding-category-iso-else 'coding-system-iso-2022-cn)
+
+ (set-coding-priority
+ '(coding-category-iso-7
+ coding-category-iso-else
+ coding-category-iso-8-2
+ coding-category-big5
+ coding-category-iso-8-1
+ coding-category-internal
+ ))
+
+ (setq-default buffer-file-coding-system 'coding-system-euc-china)
+ (set-terminal-coding-system 'coding-system-euc-china)
+ (set-keyboard-coding-system 'coding-system-euc-china)
+
+ (setq default-input-method '("Chinese-GB" . "quail-py"))
+ )
+
+(set-language-info-alist
+ "Chinese" '((documentation .
+"Emacs provides three kinds of Chinese support: Chinese-GB,
+Chinese-BIG5, and Chinese-CNS. Please specify one of them to get more
+information.")
+ (setup-function . setup-chinese-gb-environment)
+ (charset . (chinese-gb2312 chinese-sisheng))
+ (coding-system . (coding-system-euc-china
+ coding-system-hz
+ coding-system-iso-2022-cn))
+ (documentation . t)
+ (sample-text . "Chinese (\e$AVPND\e(B,\e$AFUM(;0\e(B,\e$A::So\e(B) \e$ADc:C\e(B")))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Chinese BIG5 (traditional)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(make-coding-system
+ 'coding-system-big5 3 ?B
+ "Coding-system of BIG5.")
+
+;; Big5 font requires special encoding.
+(define-ccl-program ccl-encode-big5-font
+ `(0
+ ;; In: R0:chinese-big5-1 or chinese-big5-2
+ ;; R1:position code 1
+ ;; R2:position code 2
+ ;; Out: R1:font code point 1
+ ;; R2:font code point 2
+ ((r2 = ((((r1 - ?\x21) * 94) + r2) - ?\x21))
+ (if (r0 == ,(charset-id 'chinese-big5-2)) (r2 += 6280))
+ (r1 = ((r2 / 157) + ?\xA1))
+ (r2 %= 157)
+ (if (r2 < ?\x3F) (r2 += ?\x40) (r2 += ?\x62))))
+ "CCL program to encode a Big5 code to code point of Big5 font.")
+
+(setq font-ccl-encoder-alist
+ (cons (cons "big5" ccl-encode-big5-font) font-ccl-encoder-alist))
+
+(register-input-method
+ "Chinese-BIG5" '("quail-qj-b5" quail-use-package "quail/qj-b5"))
+(register-input-method
+ "Chinese-BIG5" '("quail-zozy" quail-use-package "quail/zozy"))
+(register-input-method
+ "Chinese-BIG5" '("quail-tsangchi-b5" quail-use-package "quail/tsangchi-b5"))
+(register-input-method
+ "Chinese-BIG5" '("quail-py-b5" quail-use-package "quail/py-b5"))
+(register-input-method
+ "Chinese-BIG5" '("quail-quick-b5" quail-use-package "quail/quick-bt"))
+(register-input-method
+ "Chinese-BIG5" '("quail-etzy" quail-use-package "quail/etzy"))
+(register-input-method
+ "Chinese-BIG5" '("quail-ecdict" quail-use-package "quail/ecdict"))
+(register-input-method
+ "Chinese-BIG5" '("quail-ctlaub" quail-use-package "quail/ctlaub"))
+(register-input-method
+ "Chinese-BIG5" '("quail-array30" quail-use-package "quail/array30"))
+(register-input-method
+ "Chinese-BIG5" '("quail-4corner" quail-use-package "quail/4corner"))
+
+(defun setup-chinese-big5-environment ()
+ (setq primary-language "Chinese-BIG5")
+
+ (setq coding-category-big5 'coding-system-big5)
+ (setq coding-category-iso-else 'coding-system-iso-2022-cn)
+
+ (set-coding-priority
+ '(coding-category-iso-7
+ coding-category-iso-else
+ coding-category-big5))
+
+ (setq-default buffer-file-coding-system 'coding-system-big5)
+ (set-terminal-coding-system 'coding-system-big5)
+ (set-keyboard-coding-system 'coding-system-big5)
+
+ (setq default-input-method '("Chinese-BIG5" . "quail-py-b5"))
+ )
+
+(set-language-info-alist
+ "Chinese-BIG5" '((setup-function . setup-chinese-big5-environment)
+ (charset . (chinese-big5-1 chinese-big5-2))
+ (coding-system . (coding-system-big5
+ coding-system-iso-2022-cn))
+ (documentation . t)
+ (sample-text . "Cantonese (\e$(0GnM$\e(B,\e$(0N]0*Hd\e(B) \e$(0*/=(\e(B, \e$(0+$)p\e(B")))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Chinese CNS11643 (traditional)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(register-input-method
+ "Chinese-CNS" '("quail-quick-cns" quail-use-package "quail/quick-cns"))
+(register-input-method
+ "Chinese-CNS" '("quail-tsangchi-cns" quail-use-package "quail/tsangchi-cns"))
+
+(defun setup-chinese-cns-environment ()
+ (setq primary-language "Chinese-CNS")
+
+ (setq coding-category-iso-else 'coding-system-iso-2022-cn)
+
+ (set-coding-priority
+ '(coding-category-iso-7
+ coding-category-iso-else
+ coding-category-big5))
+
+ (setq-default buffer-file-coding-system 'coding-system-iso-2022-7)
+ (set-terminal-coding-system 'coding-system-iso-2022-7)
+ (set-keyboard-coding-system 'coding-system-iso-2022-7)
+
+ (setq default-input-method '("Chinese-CNS" . "quail-py-cns"))
+ )
+
+(set-language-info-alist
+ "Chinese-CNS" '((setup-function . setup-chinese-cns-environment)
+ (charset . (chinese-cns11643-1 chinese-cns11643-2
+ chinese-cns11643-3 chinese-cns11643-4
+ chinese-cns11643-5 chinese-cns11643-6
+ chinese-cns11643-7))
+ (coding-system . (coding-system-iso-2022-cn))
+ (documentation . t)))
+
+;;; chinese.el ends here
--- /dev/null
+;;; cyrillic.el --- Support for languages which use Cyrillic characters
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: multilingual, Cyrillic
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; The character set ISO8859-5 is supported.
+
+;;; Code:
+
+(make-coding-system
+ 'coding-system-iso-8859-5 2 ?5 "MIME ISO-8859-5"
+ '((ascii t) (cyrillic-iso8859-5 t) nil nil
+ nil ascii-eol ascii-cntl nil nil nil nil))
+
+(register-input-method
+ "Cyrillic" '("quail-jcuken" quail-use-package "quail/cyrillic"))
+(register-input-method
+ "Cyrillic" '("quail-macedonian" quail-use-package "quail/cyrillic"))
+(register-input-method
+ "Cyrillic" '("quail-serbian" quail-use-package "quail/cyrillic"))
+(register-input-method
+ "Cyrillic" '("quail-beylorussian" quail-use-package "quail/cyrillic"))
+(register-input-method
+ "Cyrillic" '("quail-ukrainian" quail-use-package "quail/cyrillic"))
+(register-input-method
+ "Cyrillic" '("quail-yawerty" quail-use-package "quail/cyrillic"))
+
+(defun setup-cyrillic-environment ()
+ (setq primary-language "Cyrillic")
+
+ (setq coding-category-iso-8-1 'coding-system-iso-8859-5)
+
+ (set-coding-priority
+ '(coding-category-iso-7
+ coding-category-iso-8-1))
+
+ (setq-default buffer-file-coding-system 'coding-system-iso-8859-5)
+ (set-terminal-coding-system 'coding-system-iso-8859-5)
+ (set-keyboard-coding-system 'coding-system-iso-8859-5)
+
+ (setq default-input-method '("Cyrillic" . "quail-yawerty"))
+ )
+
+(set-language-info-alist
+ "Cyrillic" '((setup-function . setup-cyrillic-environment)
+ (charset . (cyrillic-iso8859-5))
+ (coding-system . (coding-system-iso-8859-5))
+ (documentation . t)
+ (sample-text . "Russian (\e,L@caaZXY\e(B) \e,L7T`PRabRcYbU\e(B!")))
+
+;;; cyrillic.el ends here
--- /dev/null
+;;; devan-util.el --- Support for Devanagari Script Composition
+
+;; Copyright (C) 1996 Free Software Foundation, Inc.
+
+;; Author: KAWABATA, Taichi <kawabata@is.s.u-tokyo.ac.jp>
+
+;; Keywords: multilingual, Indian, Devanagari
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; History:
+;; 1996.10.18 written by KAWABATA, Taichi <kawabata@is.s.u-tokyo.ac.jp>
+
+;; Devanagari script composition rules and related programs.
+
+;;; Code:
+
+;;;
+;;; Steps toward composition of Devanagari Characters.
+;;;
+
+;;; Basic functions.
+
+;;;###autoload
+(defun indian-to-devanagari (ch)
+ "Convert IS 13194 characters to Devanagari basic characters."
+ (let ((charcodes (split-char ch)))
+ (if (eq (car charcodes) 'indian-is13194)
+ (make-char 'indian-2-column ?\x21 (nth 1 charcodes))
+ ch)))
+
+;;;###autoload
+(defun devanagari-to-indian (ch)
+ "Convert Devanagari basic characters to IS 13194 characters."
+ (let* ((charcodes (split-char ch))
+ (charset (car charcodes))
+ (code-h (car (cdr charcodes))))
+ (if (and (eq (car charcodes) 'indian-2-column)
+ (= (nth 1 charcodes) ?\x21))
+ (make-char 'indian-is13194 (nth 2 charcodes))
+ ch)))
+
+;;;###autoload
+(defun indian-to-devanagari-region (from to)
+ "Convert IS 13194 characters in region to Devanagari basic characters."
+ (interactive "r")
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (while (re-search-forward "\\cd" nil t)
+ (let* ((devanagari-char (indian-to-devanagari (preceding-char))))
+ (delete-char -1)
+ (insert devanagari-char)))))
+
+;;;###autoload
+(defun devanagari-to-indian-region (from to)
+ "Convert Devanagari basic characters in region to Indian characters."
+ (interactive "r")
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (while (re-search-forward "\\cD" nil t) ; Devanagari Character Code.
+ (let* ((indian-char (devanagari-to-indian (preceding-char))))
+ (delete-char -1)
+ (insert indian-char)))))
+
+;;;###autoload
+(defun indian-to-devanagari-string (str)
+ "Convert Indian String to Devanagari Basic Character String."
+ (let ((pos 0) (dst "") (src str) char)
+ (while (not (equal src ""))
+ (setq char (string-to-char src))
+ (setq src (substring src (char-bytes char)))
+ (setq dst (concat dst (char-to-string (indian-to-devanagari char)))))
+ dst))
+
+;; Phase 0 - Determine whether the characters can be composed.
+;;
+;;;
+;;; Regular expressions to split characters for composition.
+;;;
+;;
+;; Indian script word contains one or more syllables.
+;; In BNF, it can be expressed as follows:
+;;
+;; Word ::= {Syllable} [Cons-Syllable]
+;; Syllable ::= Cons-Vowel-Syllable | Vowel-Syllable
+;; Vowel-Syllable ::= V[D]
+;; Cons-Vowel-Syllable ::= [Cons-Syllable] Full-Cons [M] [D]
+;; Cons-Syllable ::= [Pure-Cons] [Pure-Cons] Pure-Cons
+;; Pure-Cons ::= Full-Cons H
+;; Full-Cons ::= C [N]
+;;
+;; {} repeat, [] optional
+;;
+;; C - Consonant (\e$(5!3!4!5!6!7!8!9!:!;!<!=!>!?!@!A!B!C!D!E\e(B
+;; \e$(5!F!G!H!I!J!K!L!M!N!O!P!Q!R!S!T!U!V!W!X\e(B)
+;; N - Nukta (\e$(5!i\e(B)
+;; H - Halant(\e$(5!h\e(B)
+;; V - Vowel (\e$(5!$!%!&!'!(!)!*!+!,!-!.!/!0!1!2\e(B)
+;; D - Vowel Modifiers, i.e. Anuswar, Chandrabindu, Visarg (\e$(5!!!"\e(B)
+;; M - Matra (\e$(5!Z![!\!]!^!_!`!a!b!c!d!e!f!g\e(B)
+;;
+;; In Emacs, one syllable of Indian language is considered to be one
+;; composite glyph. If we expand the above expression, it would be:
+;;
+;; [[C [N] H] [C [N] H] C [N] H] C [N] [M] [D] | V [D]
+;;
+;; Therefore, in worst case, the consonant syllabe will consist of
+;; following characters.
+;;
+;; C N H C N H C N H C N M D
+;;
+;; On the other hand, incomplete consonant syllable before inputting
+;; base consonant must satisfy the following condition:
+;;
+;; [C [N] H] [C [N] H] C [N] H
+;;
+;; This is acceptable BEFORE proper consonant-syllable is input. The
+;; string which doesn't match with the above expression is invalid and
+;; thus must be fixed.
+;;
+;; Note:
+;; Third case can be considered, which is acceptable syllable and can
+;; not add any code more.
+;;
+;; [[C [N] H] [C [N] H] C [N] H] C [N] [M] D
+;;
+;; However, to make editing possible even in this condition, we will
+;; not consider about this case.
+
+(defconst devanagari-cons-syllable-examine
+ "\\(\\([\e$(5!3\e(B-\e$(5!X\e(B]\e$(5!i\e(B?\e$(5!h\e(B\\)?\\([\e$(5!3\e(B-\e$(5!X\e(B]\e$(5!i\e(B?\e$(5!h\e(B\\)?[\e$(5!3\e(B-\e$(5!X\e(B]\e$(5!i\e(B?\e$(5!h\e(B\\)?[\e$(5!3\e(B-\e$(5!X\e(B]\e$(5!i\e(B?[\e$(5!Z\e(B-\e$(5!g\e(B]?[\e$(5!!!"\e(B]?"
+ "Regexp matching to one Devanagari consonant syllable.")
+
+(defconst devanagari-cons-syllable-incomplete-examine
+ "\\([\e$(5!3\e(B-\e$(5!X\e(B]\e$(5!i\e(B?\e$(5!h\e(B\\)?\\([\e$(5!3\e(B-\e$(5!X\e(B]\e$(5!i\e(B?\e$(5!h\e(B\\)?[\e$(5!3\e(B-\e$(5!X\e(B]\e$(5!i\e(B?\e$(5!h\e(B$"
+ "Regexp matching to one Devanagari incomplete consonant syllable.")
+
+(defconst devanagari-vowel-syllable-examine
+ "[\e$(5!$\e(B-\e$(5!2\e(B][\e$(5!!!"!#\e(B]?"
+ "Regexp matching to one Devanagari vowel syllable.")
+
+;;
+;; Also, digits and virams should be processed other than syllables.
+;;
+;; In IS 13194, Avagrah is obtained by Nukta after Viram, and
+;; OM is obtained by Nukta after Chandrabindu
+;;
+(defconst devanagari-digit-viram-examine
+ "[\e$(5!q\e(B-\e$(5!z!j\e(B]")
+(defconst devanagari-other-sign-examine
+ "[\e$(5!!!j\e(B]\e$(5!i\e(B")
+
+(defconst devanagari-composite-glyph-unit-examine
+ (concat "\\(" devanagari-cons-syllable-incomplete-examine
+ "\\)\\|\\(" devanagari-vowel-syllable-examine
+ "\\)\\|\\(" devanagari-digit-viram-examine
+ "\\)\\|\\(" devanagari-cons-syllable-examine
+ "\\)\\|\\(" devanagari-other-sign-examine"\\)")
+ "Regexp matching to Devanagari string to be composed form one glyph.")
+
+;;(put-charset-property charset-devanagari-1-column
+;; 'char-to-glyph 'devanagari-compose-string)
+;;(put-charset-property charset-devanagari-2-column
+;; 'char-to-glyph 'devanagari-compose-string)
+
+;; Sample
+;;
+;;(string-match devanagari-cons-syllable-examine "\e$(5!X![\e(B") => 0
+;;(string-match devanagari-cons-syllable-examine "\e$(5!F!h!D!\\e(B") => 0
+;;(string-match devanagari-cons-syllable-examine "\e$(5!X![!F!h!D!\\e(B") => 0
+
+;;
+;; Steps toward the composition
+;; Converting Character Code to Composite Glyph.
+;;
+;; Example : \e$(5!X![\e(B/\e$(5!F!h!D!\\e(B
+;;
+;; First, convert Characters to appropriate glyphs.
+;;
+;; => \e$(5!X![\e(B/\e$(5"F!D!\\e(B
+;;
+;; Then, determine the base glyph, apply-orders and apply-rules.
+;;
+;; => \e$(5!X\e(B (ml.mr) \e$(5![\e(B / \e$(5!D\e(B (ml.mr) \e$(5"F\e(B (mr ml) \e$(5!\\e(B
+;;
+;; Finally, convert 2-column glyphs to 1-column glyph
+;; if such a glyph exist.
+;;
+;; => \e$(6![\e(B (ml.mr) \e$(6!X\e(B / \e$(6!D\e(B (ml.mr) \e$(6"F\e(B (mr ml) \e$(6!\\e(B
+;;
+;; Compose the glyph.
+;;
+;; => \e2\e$(6!X@![\e1\e(B/\e2\e$(6!D@"FP!\\e1\e(B
+;; => \e2\e$(6!X@![\e1\e2!D@"FP!\\e1\e(B
+;;
+
+;;
+;; Phase 1: Converting Character Code to Glyph Code.
+;;
+;;
+;; IMPORTANT:
+;; There may be many rules which you many want to be suppressed.
+;; In that case, please comment out that rule.
+;;
+;; RULES WILL BE EVALUATED FROM FIRST TO LAST.
+;; PUT MORE SPECIFIC RULES FIRST.
+;;
+;; TO DO:
+;; Prepare multiple specific list of rules for each languages
+;; which adopts Devanagari script.
+;;
+
+
+(defconst devanagari-char-to-glyph-rules
+ '(
+ ;; special form for "ru".
+ ("\\(\e$(5!O!]\e(B\\)" . "\e$(5",\e(B")
+ ("\\(\e$(5!O!^\e(B\\)" . "\e$(5"-\e(B")
+ ("\\(\e$(5!P!]\e(B\\)" . "\e$(5".\e(B")
+ ("\\(\e$(5!P!^\e(B\\)" . "\e$(5"/\e(B")
+
+ ;; `r' at the top of syllable and followed by other consonants.
+ ;; ("[^\e$(5!h\e(B]\\(\e$(5!O!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"p\e(B")
+ ("^\\(\e$(5!O!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"p\e(B")
+
+ ;; If "r" is preceded by the vowel-suppressed consonant
+ ;; (especially those with vertical line), it will be written as
+ ;; slanted line below the preceding consonant character. Some of
+ ;; them are pre-composed as one glyph.
+
+ ("\\(\e$(5!:!i!h!O\e(B\\)" . "\e$(5"!\e(B")
+ ("\\(\e$(5!I!i!h!O\e(B\\)" . "\e$(5""\e(B")
+ ("\\(\e$(5!3!h!O\e(B\\)" . "\e$(5"#\e(B")
+ ("\\(\e$(5!:!h!O\e(B\\)" . "\e$(5"$\e(B")
+ ("\\(\e$(5!B!h!O\e(B\\)" . "\e$(5"%\e(B")
+ ("\\(\e$(5!H!h!O\e(B\\)" . "\e$(5"&\e(B")
+ ("\\(\e$(5!I!h!O\e(B\\)" . "\e$(5"'\e(B")
+ ("\\(\e$(5!U!h!O\e(B\\)" . "\e$(5"(\e(B")
+ ("\\(\e$(5!W!h!O\e(B\\)" . "\e$(5")\e(B")
+
+ ;; Ligature Rules
+ ("\\(\e$(5!3!h!B!h!O!h!M\e(B\\)" . "\e$(5$!\e(B")
+ ("\\(\e$(5!3!h!B!h!T\e(B\\)" . "\e$(5$"\e(B")
+ ("\\(\e$(5!3!h!B!h!M\e(B\\)" . "\e$(5$#\e(B")
+ ("\\(\e$(5!3!h!F!h!M\e(B\\)" . "\e$(5$$\e(B")
+ ("\\(\e$(5!3!h!O!h!M\e(B\\)" . "\e$(5$%\e(B")
+ ("\\(\e$(5!3!h!T!h!M\e(B\\)" . "\e$(5$&\e(B")
+ ("\\(\e$(5!3!h!3\e(B\\)" . "\e$(5$'\e(B")
+ ("\\(\e$(5!3!h!B\e(B\\)" . "\e$(5$(\e(B")
+ ("\\(\e$(5!3!h!F\e(B\\)" . "\e$(5$)\e(B")
+ ("\\(\e$(5!3!h!L\e(B\\)" . "\e$(5$*\e(B")
+ ("\\(\e$(5!3!h!M\e(B\\)" . "\e$(5$+\e(B")
+ ("\\(\e$(5!3!h!Q\e(B\\)" . "\e$(5$,\e(B")
+ ("\\(\e$(5!3!h!T\e(B\\)" . "\e$(5$-\e(B")
+ ("\\(\e$(5!3!h!V\e(B\\)" . "\e$(5$.\e(B")
+ ("\\(\e$(5!6!h!F\e(B\\)" . "\e$(5$/\e(B")
+ ("\\(\e$(5!7!h!3!h!B!h!M\e(B\\)" . "\e$(5$0\e(B")
+ ("\\(\e$(5!7!h!3!h!V!h!T\e(B\\)" . "\e$(5$1\e(B")
+ ("\\(\e$(5!7!h!3!h!B\e(B\\)" . "\e$(5$2\e(B")
+ ("\\(\e$(5!7!h!3!h!V\e(B\\)" . "\e$(5$3\e(B")
+ ("\\(\e$(5!7!h!6!h!O\e(B\\)" . "\e$(5$4\e(B")
+ ("\\(\e$(5!7!h!3!h!M\e(B\\)" . "\e$(5$5\e(B")
+ ("\\(\e$(5!7!h!4!h!M\e(B\\)" . "\e$(5$6\e(B")
+ ("\\(\e$(5!7!h!5!h!M\e(B\\)" . "\e$(5$7\e(B")
+ ("\\(\e$(5!7!h!6!h!M\e(B\\)" . "\e$(5$8\e(B")
+ ("\\(\e$(5!7!h!3\e(B\\)" . "\e$(5$9\e(B")
+ ("\\(\e$(5!7!h!4\e(B\\)" . "\e$(5$:\e(B")
+ ("\\(\e$(5!7!h!5\e(B\\)" . "\e$(5$;\e(B")
+ ("\\(\e$(5!7!h!6\e(B\\)" . "\e$(5$<\e(B")
+ ("\\(\e$(5!7!h!7\e(B\\)" . "\e$(5$=\e(B")
+ ("\\(\e$(5!7!h!F\e(B\\)" . "\e$(5$>\e(B")
+ ("\\(\e$(5!7!h!L\e(B\\)" . "\e$(5$?\e(B")
+ ("\\(\e$(5!7!h!M\e(B\\)" . "\e$(5$@\e(B")
+ ("\\(\e$(5!8!h!8\e(B\\)" . "\e$(5$A\e(B")
+ ("\\(\e$(5!8!h!<\e(B\\)" . "\e$(5$B\e(B")
+ ("\\(\e$(5!9!h!M\e(B\\)" . "\e$(5$C\e(B")
+ ("\\(\e$(5!:!h!O\e(B\\)" . "\e$(5$D\e(B")
+ ("\\(\e$(5!:!h!h\e(B\\)" . "\e$(5$E\e(B")
+ ("\\(\e$(5!<!h!8\e(B\\)" . "\e$(5$F\e(B")
+ ("\\(\e$(5!<!h!:\e(B\\)" . "\e$(5$G\e(B")
+ ("\\(\e$(5!=!h!3\e(B\\)" . "\e$(5$H\e(B")
+ ("\\(\e$(5!=!h!=\e(B\\)" . "\e$(5$I\e(B")
+ ("\\(\e$(5!=!h!>\e(B\\)" . "\e$(5$J\e(B")
+ ("\\(\e$(5!=!h!M\e(B\\)" . "\e$(5$K\e(B")
+ ("\\(\e$(5!>!h!M\e(B\\)" . "\e$(5$L\e(B")
+ ("\\(\e$(5!?!h!5!h!M\e(B\\)" . "\e$(5$M\e(B")
+ ("\\(\e$(5!?!h!6!h!O\e(B\\)" . "\e$(5$N\e(B")
+ ("\\(\e$(5!?!h!O!h!M\e(B\\)" . "\e$(5$O\e(B")
+ ("\\(\e$(5!?!h!5\e(B\\)" . "\e$(5$P\e(B")
+ ("\\(\e$(5!?!h!6\e(B\\)" . "\e$(5$Q\e(B")
+ ("\\(\e$(5!?!h!?\e(B\\)" . "\e$(5$R\e(B")
+ ("\\(\e$(5!?!h!L\e(B\\)" . "\e$(5$S\e(B")
+ ("\\(\e$(5!?!h!M\e(B\\)" . "\e$(5$T\e(B")
+ ("\\(\e$(5!@!h!M\e(B\\)" . "\e$(5$`\e(B")
+ ("\\(\e$(5!B!h!B\e(B\\)" . "\e$(5$a\e(B")
+ ("\\(\e$(5!B!h!F\e(B\\)" . "\e$(5$b\e(B")
+ ("\\(\e$(5!D!h!D!h!M\e(B\\)" . "\e$(5$c\e(B")
+ ("\\(\e$(5!D!h!E!h!M\e(B\\)" . "\e$(5$d\e(B")
+ ("\\(\e$(5!D!h!K!h!M\e(B\\)" . "\e$(5$e\e(B")
+ ("\\(\e$(5!D!h!O!h!M\e(B\\)" . "\e$(5$f\e(B")
+ ("\\(\e$(5!D!h!T!h!M\e(B\\)" . "\e$(5$g\e(B")
+ ("\\(\e$(5!D!h!5!h!O\e(B\\)" . "\e$(5$h\e(B")
+ ("\\(\e$(5!D!h!6!h!O\e(B\\)" . "\e$(5$i\e(B")
+ ("\\(\e$(5!D!h!D!h!T\e(B\\)" . "\e$(5$j\e(B")
+ ("\\(\e$(5!D!h!E!h!T\e(B\\)" . "\e$(5$k\e(B")
+ ("\\(\e$(5!D!h!5\e(B\\)" . "\e$(5$l\e(B")
+ ("\\(\e$(5!D!h!6\e(B\\)" . "\e$(5$m\e(B")
+ ("\\(\e$(5!D!h!D\e(B\\)" . "\e$(5$n\e(B")
+ ("\\(\e$(5!D!h!E\e(B\\)" . "\e$(5$o\e(B")
+ ("\\(\e$(5!D!h!F\e(B\\)" . "\e$(5$p\e(B")
+ ("\\(\e$(5!D!h!J\e(B\\)" . "\e$(5$q\e(B")
+ ("\\(\e$(5!D!h!K\e(B\\)" . "\e$(5$r\e(B")
+ ("\\(\e$(5!D!h!L\e(B\\)" . "\e$(5$s\e(B")
+ ("\\(\e$(5!D!h!M\e(B\\)" . "\e$(5$t\e(B")
+ ("\\(\e$(5!D!h!T\e(B\\)" . "\e$(5$u\e(B")
+ ("\\(\e$(5!E!h!F\e(B\\)" . "\e$(5$v\e(B")
+ ("\\(\e$(5!F!h!F\e(B\\)" . "\e$(5$w\e(B")
+ ("\\(\e$(5!H!h!B\e(B\\)" . "\e$(5$x\e(B")
+ ("\\(\e$(5!H!h!F\e(B\\)" . "\e$(5$y\e(B")
+ ("\\(\e$(5!H!h!Q\e(B\\)" . "\e$(5$z\e(B")
+ ("\\(\e$(5!J!h!F\e(B\\)" . "\e$(5${\e(B")
+ ("\\(\e$(5!J!h!J\e(B\\)" . "\e$(5$|\e(B")
+ ("\\(\e$(5!J!h!T\e(B\\)" . "\e$(5$}\e(B")
+ ("\\(\e$(5!K!h!F\e(B\\)" . "\e$(5$~\e(B")
+ ("\\(\e$(5!L!h!F\e(B\\)" . "\e$(5#P\e(B")
+ ("\\(\e$(5!L!h!Q\e(B\\)" . "\e$(5#Q\e(B")
+ ("\\(\e$(5!Q!h!Q\e(B\\)" . "\e$(5#`\e(B")
+ ("\\(\e$(5!T!h!F\e(B\\)" . "\e$(5#a\e(B")
+ ("\\(\e$(5!T!h!T\e(B\\)" . "\e$(5#b\e(B")
+ ("\\(\e$(5!U!h!8\e(B\\)" . "\e$(5#c\e(B")
+ ("\\(\e$(5!U!h!F\e(B\\)" . "\e$(5#d\e(B")
+ ("\\(\e$(5!U!h!J\e(B\\)" . "\e$(5#e\e(B")
+ ("\\(\e$(5!U!h!Q\e(B\\)" . "\e$(5#f\e(B")
+ ("\\(\e$(5!U!h!T\e(B\\)" . "\e$(5#g\e(B")
+ ("\\(\e$(5!V!h!=!h!O!h!M\e(B\\)" . "\e$(5#h\e(B")
+ ("\\(\e$(5!V!h!=!h!M\e(B\\)" . "\e$(5#i\e(B")
+ ("\\(\e$(5!V!h!=!h!T\e(B\\)" . "\e$(5#j\e(B")
+ ("\\(\e$(5!V!h!=\e(B\\)" . "\e$(5#k\e(B")
+ ("\\(\e$(5!V!h!>\e(B\\)" . "\e$(5#l\e(B")
+ ("\\(\e$(5!W!h!F\e(B\\)" . "\e$(5#m\e(B")
+ ("\\(\e$(5!W!h!O\e(B\\)" . "\e$(5#n\e(B")
+ ("\\(\e$(5!X!h!A\e(B\\)" . "\e$(5#p\e(B")
+ ("\\(\e$(5!X!h!F\e(B\\)" . "\e$(5#q\e(B")
+ ("\\(\e$(5!X!h!L\e(B\\)" . "\e$(5#r\e(B")
+ ("\\(\e$(5!X!h!M\e(B\\)" . "\e$(5#s\e(B")
+ ("\\(\e$(5!X!h!O\e(B\\)" . "\e$(5#t\e(B")
+ ("\\(\e$(5!X!h!Q\e(B\\)" . "\e$(5#u\e(B")
+ ("\\(\e$(5!X!h!T\e(B\\)" . "\e$(5#v\e(B")
+ ;; Special Ligature Rules
+ ("\\(\e$(5!X!_\e(B\\)" . "\e$(5#R\e(B")
+
+ ;; Half form with ligature. Special "r" case is included. "r"
+ ;; connection which is not listed here has not been examined yet.
+ ;; I don't know what to do with them.
+ ;;
+ ;; special forms
+ ("\\(\e$(5!3!h!V!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"l\e(B")
+ ("\\(\e$(5!:!h!<!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"m\e(B")
+ ;; ordinary forms
+ ("\\(\e$(5!5!h!O!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"`\e(B")
+ ("\\(\e$(5!6!h!F!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"a\e(B")
+ ;; ("\\(\e$(5!<!h!8!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"c\e(B") ; Mistake, must check later.
+ ("\\(\e$(5!B!h!B!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"c\e(B")
+ ("\\(\e$(5!B!h!O!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"d\e(B")
+ ("\\(\e$(5!E!h!F!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"e\e(B")
+ ("\\(\e$(5!E!h!O!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"f\e(B")
+ ("\\(\e$(5!H!h!B!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"g\e(B")
+ ("\\(\e$(5!U!h!8!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"h\e(B")
+ ("\\(\e$(5!U!h!O!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"i\e(B")
+ ("\\(\e$(5!U!h!T!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"j\e(B")
+ ;; ("\\(\e$(5!U!h!T!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"k\e(B") ; must check later.
+ ;; Conjunction form associated with Nukta sign.
+ ("\\(\e$(5!3!i!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"s\e(B")
+ ("\\(\e$(5!4!i!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"t\e(B")
+ ("\\(\e$(5!5!i!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"u\e(B")
+ ("\\(\e$(5!:!i!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"z\e(B")
+ ("\\(\e$(5!I!i!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"y\e(B")
+
+ ;; For consonants other than listed above, glyph-composition will
+ ;; be applied. If the consonant which is preceding "\e$(5!O\e(B" does not
+ ;; have the vertical line (such as "\e$(5!?\e(B"), "\e$(5"r\e(B" is put beneath the
+ ;; consonant.
+ ;;
+ ;; ("cons-not-yet-listed-up\\(\e$(5!h!O\e(B\\)" . "\e$(5"q\e(B")
+ ("[\e$(5!7!9!=!>!?!@!D!O!P!R!S!X\e(B]\\(\e$(5!h!O\e(B\\)" . "\e$(5"r\e(B")
+ ("\e$(5!?!i\e(B\\(\e$(5!h!O\e(B\\)" . "\e$(5"r\e(B")
+ ("\e$(5!@!i\e(B\\(\e$(5!h!O\e(B\\)" . "\e$(5"r\e(B")
+
+ ;; Nukta
+ ("\\(\e$(5!!!i\e(B\\)" . "\e$(5#!\e(B")
+ ("\\(\e$(5!&!i\e(B\\)" . "\e$(5#&\e(B")
+ ("\\(\e$(5!'!i\e(B\\)" . "\e$(5#'\e(B")
+ ("\\(\e$(5!*!i\e(B\\)" . "\e$(5#*\e(B")
+ ("\\(\e$(5!3!i\e(B\\)" . "\e$(5#3\e(B")
+ ("\\(\e$(5!4!i\e(B\\)" . "\e$(5#4\e(B")
+ ("\\(\e$(5!5!i\e(B\\)" . "\e$(5#5\e(B")
+ ("\\(\e$(5!:!i\e(B\\)" . "\e$(5#:\e(B")
+ ("\\(\e$(5!?!i\e(B\\)" . "\e$(5#?\e(B")
+ ("\\(\e$(5!@!i\e(B\\)" . "\e$(5#@\e(B")
+ ("\\(\e$(5!I!i\e(B\\)" . "\e$(5#I\e(B")
+ ("\\(\e$(5!j!i\e(B\\)" . "\e$(5#J\e(B")
+
+ ;; Half forms.
+ ("\\(\e$(5!3!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"3\e(B")
+ ("\\(\e$(5!4!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"4\e(B")
+ ("\\(\e$(5!5!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"5\e(B")
+ ("\\(\e$(5!6!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"6\e(B")
+ ("\\(\e$(5!8!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"8\e(B")
+ ("\\(\e$(5!:!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5":\e(B")
+ ("\\(\e$(5!;!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5";\e(B")
+ ("\\(\e$(5!<!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"<\e(B")
+ ("\\(\e$(5!A!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"A\e(B")
+ ("\\(\e$(5!B!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"B\e(B")
+ ("\\(\e$(5!C!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"C\e(B")
+ ("\\(\e$(5!E!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"E\e(B")
+ ("\\(\e$(5!F!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"F\e(B")
+ ("\\(\e$(5!G!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"G\e(B")
+ ("\\(\e$(5!H!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"H\e(B")
+ ("\\(\e$(5!I!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"I\e(B")
+ ("\\(\e$(5!J!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"J\e(B")
+ ("\\(\e$(5!K!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"K\e(B")
+ ("\\(\e$(5!L!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"L\e(B")
+ ("\\(\e$(5!M!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"M\e(B")
+ ("\\(\e$(5!N!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"N\e(B")
+ ("\\(\e$(5!Q!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"Q\e(B")
+ ("\\(\e$(5!R!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"R\e(B")
+ ("\\(\e$(5!S!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"S\e(B")
+ ("\\(\e$(5!T!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"T\e(B")
+ ("\\(\e$(5!U!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"U\e(B")
+ ("\\(\e$(5!V!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"V\e(B")
+ ("\\(\e$(5!W!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"W\e(B")
+ )
+ "Alist of regexps of Devanagari character sequences vs composed characters.")
+
+;; Example:
+;;("\\(\e$(5!F!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" . "\e$(5"F\e(B")
+;;(string-match "\\(\e$(5!F!h\e(B\\)[\e$(5!3\e(B-\e$(5!X\e(B]" "\e$(5!X![!F!h!D!\\e(B") => 8
+;;(match-end 1) => 16
+
+;;
+;; Defining character properties : char-to-glyph, glyph-to-char
+;;
+;; * If char-to-glyph is non-nil, it would be one of the following forms.
+;;
+;; (("character-regexp" . "glyphs")
+;; .....) or
+;; (("character-regexp" . ?glyph)
+;; .....) or
+;; ("characters-regexp" . "glyphs")
+;; or
+;; ?glyph
+;;
+;; * If glyph-to-char is non-nil, it would be one of the following forms.
+;;
+;; (("glyph-regexp" . "characters") ;; This is the only case in Devanagari
+;; ....) or
+;; (("glyph-regexp" . ?character)
+;; ....) or
+;; ("glyph-regexp" . "characters")
+;; or
+;; "characters"
+;; or
+;; ?character
+;;
+
+(let ((rules devanagari-char-to-glyph-rules))
+ (while rules
+ (let ((rule (car rules))
+ (chars) (char) (glyph))
+ (setq rules (cdr rules))
+ (string-match "\\\\(\\(.+\\)\\\\)" (car rule))
+ (setq chars (substring (car rule) (match-beginning 1) (match-end 1)))
+ (setq char (string-to-char chars))
+ (setq glyph (string-to-char (cdr rule))) ; assume one glyph in devan.
+ (put-char-code-property
+ char 'char-to-glyph
+ (append (get-char-code-property char 'char-to-glyph) (list rule)))
+ (put-char-code-property glyph 'glyph-to-char chars))))
+
+;;
+;; Convert Character Code to Glyph Code
+;;
+
+;;;###autoload
+(defun char-to-glyph-devanagari (src-str)
+ "Convert Devanagari characters in the string to Devanagari glyphs.
+Ligatures and special rules are processed."
+ (let ((pos 0)
+ (dst-str ""))
+ (while (< pos (length src-str))
+ (let ((found nil)
+ (rules (get-char-code-property
+ (string-to-char
+ ;; caution. other forms not supported for now.
+ (substring src-str pos)) 'char-to-glyph)))
+ (while rules
+ (let* ((rule (car rules))
+ (regexp (car rule)))
+ (if (string-match regexp src-str)
+ (if (= (match-beginning 1) pos)
+ (progn
+ (setq dst-str (concat dst-str (cdr rule)))
+ (setq rules nil) ; Get out of the loop.
+ (setq found t)
+ ;; proceed `pos' for replaced characters.
+ (setq pos (match-end 1)))
+ (setq rules (cdr rules)))
+ (setq rules (cdr rules)))))
+ ;; proceed to next position
+ (if (not found)
+ (let ((nextchar (string-to-char (substring src-str pos))))
+ (setq pos (+ pos
+ (char-bytes (string-to-char (substring src-str pos)))))
+ (setq dst-str (concat dst-str (char-to-string nextchar)))))))
+ dst-str))
+
+;; Example:
+;;(char-to-glyph-devanagari "\e$(5!X![!F!h!D!\\e(B") => "\e$(5!X!["F!D!\\e(B"
+;;(char-to-glyph-devanagari "\e$(5!O!Z!V!h!=!h!O![!M\e(B") => ???
+
+;;
+;; Phase 2: Compose Glyphs to form One Glyph.
+;;
+
+;; Each list consist of glyph, application-priority and application-direction.
+;;
+;; Glyphs will be ordered from low priority number to high priority number.
+;; If application-priority is omitted, it is assumed to be 0.
+;; If application-direction is omitted, it is asumbed to be '(mr . ml).
+
+(defconst devanagari-composition-rules
+ '((?\e$(5!!\e(B 60 (tr . br))
+ (?\e$(5!"\e(B 60 (tr . br))
+ (?\e$(5!#\e(B 60)
+ (?\e$(5!$\e(B 0)
+ (?\e$(5!%\e(B 0)
+ (?\e$(5!&\e(B 0)
+ (?\e$(5!'\e(B 0)
+ (?\e$(5!(\e(B 0)
+ (?\e$(5!)\e(B 0)
+ (?\e$(5!*\e(B 0)
+ (?\e$(5!+\e(B 0)
+ (?\e$(5!,\e(B 0)
+ (?\e$(5!-\e(B 0)
+ (?\e$(5!.\e(B 0)
+ (?\e$(5!/\e(B 0)
+ (?\e$(5!0\e(B 0)
+ (?\e$(5!1\e(B 0)
+ (?\e$(5!2\e(B 0)
+ (?\e$(5!3\e(B 0)
+ (?\e$(5!4\e(B 0)
+ (?\e$(5!5\e(B 0)
+ (?\e$(5!6\e(B 0)
+ (?\e$(5!7\e(B 0)
+ (?\e$(5!8\e(B 0)
+ (?\e$(5!9\e(B 0)
+ (?\e$(5!:\e(B 0)
+ (?\e$(5!;\e(B 0)
+ (?\e$(5!<\e(B 0)
+ (?\e$(5!=\e(B 0)
+ (?\e$(5!>\e(B 0)
+ (?\e$(5!?\e(B 0)
+ (?\e$(5!@\e(B 0)
+ (?\e$(5!A\e(B 0)
+ (?\e$(5!B\e(B 0)
+ (?\e$(5!C\e(B 0)
+ (?\e$(5!D\e(B 0)
+ (?\e$(5!E\e(B 0)
+ (?\e$(5!F\e(B 0)
+ (?\e$(5!G\e(B 0)
+ (?\e$(5!H\e(B 0)
+ (?\e$(5!I\e(B 0)
+ (?\e$(5!J\e(B 0)
+ (?\e$(5!K\e(B 0)
+ (?\e$(5!L\e(B 0)
+ (?\e$(5!M\e(B 0)
+ (?\e$(5!N\e(B 0)
+ (?\e$(5!O\e(B 0)
+ (?\e$(5!P\e(B 0)
+ (?\e$(5!Q\e(B 0)
+ (?\e$(5!R\e(B 0)
+ (?\e$(5!S\e(B 0)
+ (?\e$(5!T\e(B 0)
+ (?\e$(5!U\e(B 0)
+ (?\e$(5!V\e(B 0)
+ (?\e$(5!W\e(B 0)
+ (?\e$(5!X\e(B 0)
+ (?\e$(5!Y\e(B 0)
+ (?\e$(5!Z\e(B 40)
+ (?\e$(5![\e(B 40 (ml . mr))
+ (?\e$(5!\\e(B 40)
+ (?\e$(5!]\e(B 40 (bc . tc))
+ (?\e$(5!^\e(B 40 (bc . tc))
+ (?\e$(5!_\e(B 40 (bc . tc))
+ (?\e$(5!`\e(B 40 (tc . bc))
+ (?\e$(5!a\e(B 40 (tc . bc))
+ (?\e$(5!b\e(B 40 (tc . bc))
+ (?\e$(5!c\e(B 40 (tc . bc))
+ (?\e$(5!d\e(B 40)
+ (?\e$(5!e\e(B 40)
+ (?\e$(5!f\e(B 40)
+ (?\e$(5!g\e(B 40)
+ (?\e$(5!h\e(B 0 (br . tr)) ; Halant's special treatment.
+ (?\e$(5!i\e(B 0 (br . tr)) ; Nukta's special treatment.
+ (?\e$(5!j\e(B 0)
+ (nil 0)
+ (nil 0)
+ (nil 0)
+ (nil 0)
+ (nil 0)
+ (nil 0)
+ (?\e$(5!q\e(B 0)
+ (?\e$(5!r\e(B 0)
+ (?\e$(5!s\e(B 0)
+ (?\e$(5!t\e(B 0)
+ (?\e$(5!u\e(B 0)
+ (?\e$(5!v\e(B 0)
+ (?\e$(5!w\e(B 0)
+ (?\e$(5!x\e(B 0)
+ (?\e$(5!y\e(B 0)
+ (?\e$(5!z\e(B 0)
+ (nil 0)
+ (nil 0)
+ (nil 0)
+ (nil 0)
+ (?\e$(5"!\e(B 0)
+ (?\e$(5""\e(B 0)
+ (?\e$(5"#\e(B 0)
+ (?\e$(5"$\e(B 0)
+ (?\e$(5"%\e(B 0)
+ (?\e$(5"&\e(B 0)
+ (?\e$(5"'\e(B 0)
+ (?\e$(5"(\e(B 0)
+ (?\e$(5")\e(B 0)
+ (?\e$(5"*\e(B 0)
+ (?\e$(5"+\e(B 0)
+ (?\e$(5",\e(B 0)
+ (?\e$(5"-\e(B 0)
+ (?\e$(5".\e(B 0)
+ (?\e$(5"/\e(B 0)
+ (?\e$(5"0\e(B 0)
+ (?\e$(5"1\e(B 0)
+ (?\e$(5"2\e(B 0)
+ (?\e$(5"3\e(B 0)
+ (?\e$(5"4\e(B 0)
+ (?\e$(5"5\e(B 0)
+ (?\e$(5"6\e(B 0)
+ (?\e$(5"7\e(B 0)
+ (?\e$(5"8\e(B 0)
+ (?\e$(5"9\e(B 0)
+ (?\e$(5":\e(B 0)
+ (?\e$(5";\e(B 0)
+ (?\e$(5"<\e(B 0)
+ (?\e$(5"=\e(B 0)
+ (?\e$(5">\e(B 0)
+ (?\e$(5"?\e(B 0)
+ (?\e$(5"@\e(B 0)
+ (?\e$(5"A\e(B 0)
+ (?\e$(5"B\e(B 0)
+ (?\e$(5"C\e(B 0)
+ (?\e$(5"D\e(B 0)
+ (?\e$(5"E\e(B 0)
+ (?\e$(5"F\e(B 0)
+ (?\e$(5"G\e(B 0)
+ (?\e$(5"H\e(B 0)
+ (?\e$(5"I\e(B 0)
+ (?\e$(5"J\e(B 0)
+ (?\e$(5"K\e(B 0)
+ (?\e$(5"L\e(B 0)
+ (?\e$(5"M\e(B 0)
+ (?\e$(5"N\e(B 0)
+ (?\e$(5"O\e(B 0)
+ (?\e$(5"P\e(B 0)
+ (?\e$(5"Q\e(B 0)
+ (?\e$(5"R\e(B 0)
+ (?\e$(5"S\e(B 0)
+ (?\e$(5"T\e(B 0)
+ (?\e$(5"U\e(B 0)
+ (?\e$(5"V\e(B 0)
+ (?\e$(5"W\e(B 0)
+ (?\e$(5"X\e(B 0)
+ (?\e$(5"Y\e(B 0)
+ (?\e$(5"Z\e(B 0)
+ (?\e$(5"[\e(B 0)
+ (?\e$(5"\\e(B 0)
+ (?\e$(5"]\e(B 0)
+ (?\e$(5"^\e(B 0)
+ (?\e$(5"_\e(B 0)
+ (?\e$(5"`\e(B 0)
+ (?\e$(5"a\e(B 0)
+ (?\e$(5"b\e(B 0)
+ (?\e$(5"c\e(B 0)
+ (?\e$(5"d\e(B 0)
+ (?\e$(5"e\e(B 0)
+ (?\e$(5"f\e(B 0)
+ (?\e$(5"g\e(B 0)
+ (?\e$(5"h\e(B 0)
+ (?\e$(5"i\e(B 0)
+ (?\e$(5"j\e(B 0)
+ (?\e$(5"k\e(B 0)
+ (?\e$(5"l\e(B 0)
+ (?\e$(5"m\e(B 0)
+ (?\e$(5"n\e(B 0)
+ (?\e$(5"o\e(B 0)
+ (?\e$(5"p\e(B 20 (tr . br))
+ (?\e$(5"q\e(B 20 (br . tr))
+ (?\e$(5"r\e(B 20 (br . tr))
+ (?\e$(5"s\e(B 0)
+ (?\e$(5"t\e(B 0)
+ (?\e$(5"u\e(B 0)
+ (?\e$(5"v\e(B 0)
+ (?\e$(5"w\e(B 0)
+ (?\e$(5"x\e(B 0)
+ (?\e$(5"y\e(B 0)
+ (?\e$(5"z\e(B 0)
+ (?\e$(5"{\e(B 0)
+ (?\e$(5"|\e(B 0)
+ (?\e$(5"}\e(B 0)
+ (?\e$(5"~\e(B 0)
+ (?\e$(5#!\e(B 0)
+ (?\e$(5#"\e(B 0)
+ (?\e$(5##\e(B 0)
+ (?\e$(5#$\e(B 0)
+ (?\e$(5#%\e(B 0)
+ (?\e$(5#&\e(B 0)
+ (?\e$(5#'\e(B 0)
+ (?\e$(5#(\e(B 0)
+ (?\e$(5#)\e(B 0)
+ (?\e$(5#*\e(B 0)
+ (?\e$(5#+\e(B 0)
+ (?\e$(5#,\e(B 0)
+ (?\e$(5#-\e(B 0)
+ (?\e$(5#.\e(B 0)
+ (?\e$(5#/\e(B 0)
+ (?\e$(5#0\e(B 0)
+ (?\e$(5#1\e(B 0)
+ (?\e$(5#2\e(B 0)
+ (?\e$(5#3\e(B 0)
+ (?\e$(5#4\e(B 0)
+ (?\e$(5#5\e(B 0)
+ (?\e$(5#6\e(B 0)
+ (?\e$(5#7\e(B 0)
+ (?\e$(5#8\e(B 0)
+ (?\e$(5#9\e(B 0)
+ (?\e$(5#:\e(B 0)
+ (?\e$(5#;\e(B 0)
+ (?\e$(5#<\e(B 0)
+ (?\e$(5#=\e(B 0)
+ (?\e$(5#>\e(B 0)
+ (?\e$(5#?\e(B 0)
+ (?\e$(5#@\e(B 0)
+ (?\e$(5#A\e(B 0)
+ (?\e$(5#B\e(B 0)
+ (?\e$(5#C\e(B 0)
+ (?\e$(5#D\e(B 0)
+ (?\e$(5#E\e(B 0)
+ (?\e$(5#F\e(B 0)
+ (?\e$(5#G\e(B 0)
+ (?\e$(5#H\e(B 0)
+ (?\e$(5#I\e(B 0)
+ (?\e$(5#J\e(B 0)
+ (?\e$(5#K\e(B 0)
+ (?\e$(5#L\e(B 0)
+ (?\e$(5#M\e(B 0)
+ (?\e$(5#N\e(B 0)
+ (?\e$(5#O\e(B 0)
+ (?\e$(5#P\e(B 0)
+ (?\e$(5#Q\e(B 0)
+ (?\e$(5#R\e(B 0)
+ (?\e$(5#S\e(B 0)
+ (?\e$(5#T\e(B 0)
+ (?\e$(5#U\e(B 0)
+ (?\e$(5#V\e(B 0)
+ (?\e$(5#W\e(B 0)
+ (?\e$(5#X\e(B 0)
+ (?\e$(5#Y\e(B 0)
+ (?\e$(5#Z\e(B 0)
+ (?\e$(5#[\e(B 0)
+ (?\e$(5#\\e(B 0)
+ (?\e$(5#]\e(B 0)
+ (?\e$(5#^\e(B 0)
+ (?\e$(5#_\e(B 0)
+ (?\e$(5#`\e(B 0)
+ (?\e$(5#a\e(B 0)
+ (?\e$(5#b\e(B 0)
+ (?\e$(5#c\e(B 0)
+ (?\e$(5#d\e(B 0)
+ (?\e$(5#e\e(B 0)
+ (?\e$(5#f\e(B 0)
+ (?\e$(5#g\e(B 0)
+ (?\e$(5#h\e(B 0)
+ (?\e$(5#i\e(B 0)
+ (?\e$(5#j\e(B 0)
+ (?\e$(5#k\e(B 0)
+ (?\e$(5#l\e(B 0)
+ (?\e$(5#m\e(B 0)
+ (?\e$(5#n\e(B 0)
+ (?\e$(5#o\e(B 0)
+ (?\e$(5#p\e(B 0)
+ (?\e$(5#q\e(B 0)
+ (?\e$(5#r\e(B 0)
+ (?\e$(5#s\e(B 0)
+ (?\e$(5#t\e(B 0)
+ (?\e$(5#u\e(B 0)
+ (?\e$(5#v\e(B 0)
+ (?\e$(5#w\e(B 0)
+ (?\e$(5#x\e(B 0)
+ (?\e$(5#y\e(B 0)
+ (?\e$(5#z\e(B 0)
+ (?\e$(5#{\e(B 0)
+ (?\e$(5#|\e(B 0)
+ (?\e$(5#}\e(B 0)
+ (?\e$(5#~\e(B 0)
+ (?\e$(5$!\e(B 0)
+ (?\e$(5$"\e(B 0)
+ (?\e$(5$#\e(B 0)
+ (?\e$(5$$\e(B 0)
+ (?\e$(5$%\e(B 0)
+ (?\e$(5$&\e(B 0)
+ (?\e$(5$'\e(B 0)
+ (?\e$(5$(\e(B 0)
+ (?\e$(5$)\e(B 0)
+ (?\e$(5$*\e(B 0)
+ (?\e$(5$+\e(B 0)
+ (?\e$(5$,\e(B 0)
+ (?\e$(5$-\e(B 0)
+ (?\e$(5$.\e(B 0)
+ (?\e$(5$/\e(B 0)
+ (?\e$(5$0\e(B 0)
+ (?\e$(5$1\e(B 0)
+ (?\e$(5$2\e(B 0)
+ (?\e$(5$3\e(B 0)
+ (?\e$(5$4\e(B 0)
+ (?\e$(5$5\e(B 0)
+ (?\e$(5$6\e(B 0)
+ (?\e$(5$7\e(B 0)
+ (?\e$(5$8\e(B 0)
+ (?\e$(5$9\e(B 0)
+ (?\e$(5$:\e(B 0)
+ (?\e$(5$;\e(B 0)
+ (?\e$(5$<\e(B 0)
+ (?\e$(5$=\e(B 0)
+ (?\e$(5$>\e(B 0)
+ (?\e$(5$?\e(B 0)
+ (?\e$(5$@\e(B 0)
+ (?\e$(5$A\e(B 0)
+ (?\e$(5$B\e(B 0)
+ (?\e$(5$C\e(B 0)
+ (?\e$(5$D\e(B 0)
+ (?\e$(5$E\e(B 0)
+ (?\e$(5$F\e(B 0)
+ (?\e$(5$G\e(B 0)
+ (?\e$(5$H\e(B 0)
+ (?\e$(5$I\e(B 0)
+ (?\e$(5$J\e(B 0)
+ (?\e$(5$K\e(B 0)
+ (?\e$(5$L\e(B 0)
+ (?\e$(5$M\e(B 0)
+ (?\e$(5$N\e(B 0)
+ (?\e$(5$O\e(B 0)
+ (?\e$(5$P\e(B 0)
+ (?\e$(5$Q\e(B 0)
+ (?\e$(5$R\e(B 0)
+ (?\e$(5$S\e(B 0)
+ (?\e$(5$T\e(B 0)
+ (?\e$(5$U\e(B 0)
+ (?\e$(5$V\e(B 0)
+ (?\e$(5$W\e(B 0)
+ (?\e$(5$X\e(B 0)
+ (?\e$(5$Y\e(B 0)
+ (?\e$(5$Z\e(B 0)
+ (?\e$(5$[\e(B 0)
+ (?\e$(5$\\e(B 0)
+ (?\e$(5$]\e(B 0)
+ (?\e$(5$^\e(B 0)
+ (?\e$(5$_\e(B 0)
+ (?\e$(5$`\e(B 0)
+ (?\e$(5$a\e(B 0)
+ (?\e$(5$b\e(B 0)
+ (?\e$(5$c\e(B 0)
+ (?\e$(5$d\e(B 0)
+ (?\e$(5$e\e(B 0)
+ (?\e$(5$f\e(B 0)
+ (?\e$(5$g\e(B 0)
+ (?\e$(5$h\e(B 0)
+ (?\e$(5$i\e(B 0)
+ (?\e$(5$j\e(B 0)
+ (?\e$(5$k\e(B 0)
+ (?\e$(5$l\e(B 0)
+ (?\e$(5$m\e(B 0)
+ (?\e$(5$n\e(B 0)
+ (?\e$(5$o\e(B 0)
+ (?\e$(5$p\e(B 0)
+ (?\e$(5$q\e(B 0)
+ (?\e$(5$r\e(B 0)
+ (?\e$(5$s\e(B 0)
+ (?\e$(5$t\e(B 0)
+ (?\e$(5$u\e(B 0)
+ (?\e$(5$v\e(B 0)
+ (?\e$(5$w\e(B 0)
+ (?\e$(5$x\e(B 0)
+ (?\e$(5$y\e(B 0)
+ (?\e$(5$z\e(B 0)
+ (?\e$(5${\e(B 0)
+ (?\e$(5$|\e(B 0)
+ (?\e$(5$}\e(B 0)
+ (?\e$(5$~\e(B 0)
+ ))
+
+;; Determine composition priority and rule of the array of Glyphs.
+;; Sort the glyphs with their priority.
+
+;; Example:
+;;(devanagari-reorder-glyph-for-composition '[?\e$(5"5\e(B ?\e$(5!X\e(B ?\e$(5![\e(B])
+;; => ((446680 0) (446773 0) (446683 50 (ml . mr)))
+
+(defun devanagari-reorder-glyph-for-composition (glyph-alist)
+ (let* ((pos 0)
+ (ordered-glyphs '()))
+ (while (< pos (length glyph-alist))
+ (let* ((glyph (aref glyph-alist pos)))
+ (setq pos (1+ pos))
+ (setq ordered-glyphs
+ (append ordered-glyphs (list (assq glyph devanagari-composition-rules))))))
+ (sort ordered-glyphs '(lambda (x y) (< (car (cdr x)) (car (cdr y)))))))
+
+;;(devanagari-compose-to-one-glyph "\e$(5"5!X![\e(B") => "\e2\e$(6!XP"5@![\e1\e(B"
+
+(defun devanagari-compose-to-one-glyph (devanagari-string)
+ (let* ((o-glyph-list (devanagari-reorder-glyph-for-composition
+ (string-to-vector devanagari-string)))
+ ;; List of glyphs to be composed.
+ (cmp-glyph-list (list (car (car o-glyph-list))))
+ (o-glyph-list (cdr o-glyph-list)))
+ (while o-glyph-list
+ (let* ((o-glyph (car o-glyph-list))
+ (glyph (if (< 2 (length o-glyph))
+ ;; default composition
+ (list (car (cdr (cdr o-glyph))) (car o-glyph))
+ ;; composition with a specified rule
+ (list '(mr . ml) (car o-glyph)))))
+ (setq o-glyph-list (cdr o-glyph-list))
+ (setq cmp-glyph-list (append cmp-glyph-list glyph))))
+ ;; Before applying compose-chars, convert glyphs to
+ ;; 1-column width if possible.
+ (setq cmp-glyph-list (devanagari-wide-to-narrow cmp-glyph-list))
+ (if (= (length cmp-glyph-list) 1) (char-to-string (car cmp-glyph-list))
+ (apply 'compose-chars cmp-glyph-list))))
+
+
+;;
+;; Phase 2.5 Convert Appropriate Character to 1-column shape.
+;;
+;; This is temporary and should be removed out when Emacs supports
+;; variable width characters.
+;;
+;; This will convert the composing glyphs (2 column glyphs)
+;; to narrow (1 column) glyphs if they exist.
+;;
+;; devanagari-wide-to-narrow-old converts glyphs simply.
+;; devanagari-wide-to-narrow takes care of upper/lower apply-glyphs
+;; with 2 column base-glyph.
+;;
+;; Execution Examples
+;;(devanagari-wide-to-narrow '(446680 446773 (ml . mr) 446683))
+;;(devanagari-wide-to-narrow '(?\e$(5!6\e(B (ml . ml) 446773 (tc . mr) 446683))
+
+(defun devanagari-wide-to-narrow (src-list)
+ (if (null src-list) '()
+ (cons
+ (if (and (numberp (car src-list))
+ (cdr (assq (car src-list) devanagari-1-column-char)))
+ (cdr (assq (car src-list) devanagari-1-column-char))
+ (car src-list))
+ (devanagari-wide-to-narrow (cdr src-list)))))
+
+;; Make this function obsolete temporary Because now Emacs supports
+;; attaching 1 column character at the center 2 column char. However,
+;; there are still problems attempting to attach Halant or Nukta sign
+;; at the non-vowel consonant. This problem can not be solved until
+;; Emacs supports attaching the glyph at `temporary-preserved metric'.
+
+(defun devanagari-wide-to-narrow-old (src-list)
+ (if (null src-list) (progn (error "devanagari-wide-to-narrow error") nil)
+ (let* ((base-glyph (cdr (assq (car src-list) devanagari-1-column-char)))
+ (wide-base-glyph nil)
+ (apply-glyph-list (cdr src-list)))
+ (if (null base-glyph)
+ (progn
+ (setq wide-base-glyph t)
+ (setq base-glyph (car src-list))))
+ (cons base-glyph
+ (devanagari-wide-to-narrow-iter apply-glyph-list wide-base-glyph))
+ )))
+
+;; Convert apply-glyph-list from 2-column to 1-column.
+;; wide-base-glyph is t when base-glyph is 2-column.
+;; When apply-glyph is put at the top or bottom of 2-column base-glyph,
+;; they must be 2-column glyph, too. Otherwise, they will be
+;; converted to 1-column glyph if possible.
+
+(defun devanagari-wide-to-narrow-iter (apply-glyph-list wide-base-glyph)
+ (if (< (length apply-glyph-list) 2) '()
+ (let* ((apply-dir (car apply-glyph-list))
+ (apply-glyph (car (cdr apply-glyph-list)))
+ (apply-rest (cdr (cdr apply-glyph-list)))
+ (put-t-or-b (member (car apply-dir) '(tl tc tr bl bc br)))
+ (narrow-glyph (cdr (assq apply-glyph devanagari-1-column-char))))
+ (append
+ (list apply-dir
+ (if (or (and wide-base-glyph put-t-or-b)
+ (null narrow-glyph))
+ apply-glyph narrow-glyph))
+ (devanagari-wide-to-narrow-iter apply-rest wide-base-glyph)))))
+
+;;
+;; Summary
+;;
+
+;;;###autoload
+(defun devanagari-compose-string (str)
+ (let ((len (length str))
+ (src str) (dst "") rest match-b match-e)
+ (while (string-match devanagari-composite-glyph-unit-examine src)
+ (setq match-b (match-beginning 0) match-e (match-end 0))
+ (setq dst
+ (concat dst
+ (substring src 0 match-b)
+ (devanagari-compose-to-one-glyph
+ (char-to-glyph-devanagari
+ (substring src match-b match-e)))))
+ (setq src (substring src match-e)))
+ (setq dst (concat dst src))
+ dst))
+
+;;;###autoload
+(defun devanagari-compose-region (from to)
+ (interactive "r")
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (while (re-search-forward devanagari-composite-glyph-unit-examine nil t)
+ (let* ((match-b (match-beginning 0)) (match-e (match-end 0))
+ (cmps (devanagari-compose-to-one-glyph
+ (char-to-glyph-devanagari
+ (buffer-substring match-b match-e)))))
+ (delete-region match-b match-e)
+ (insert cmps)))))
+
+;;
+;; Decomposition of composite font.
+;;
+
+(defun devanagari-normalize-narrow-glyph (charlist)
+ (let ((wide-char (car (rassoc (car charlist) devanagari-1-column-char))))
+ (if (null charlist) nil
+ (cons (if (null wide-char) (car charlist) wide-char)
+ (devanagari-normalize-narrow-glyph (cdr charlist))))))
+
+(defvar devanagari-decomposition-rules
+ '(
+ (?\e$(5"p\e(B -20)
+ )
+ )
+
+(defun devanagari-reorder-glyph-for-decomposition (glyphlist)
+ "This function re-orders glyph list."
+ (sort glyphlist
+ '(lambda (x y)
+ (let ((xx (assoc x devanagari-decomposition-rules))
+ (yy (assoc y devanagari-decomposition-rules)))
+ (if (null xx) (setq xx 0))
+ (if (null yy) (setq yy 0))
+ (< xx yy)))))
+
+(defun devanagari-decompose-char (char)
+ "This function decomposes one Devanagari composite character to
+ basic Devanagari character."
+ (let ((glyphlist (decompose-composite-char char)))
+ (if (not (listp glyphlist))
+ (setq glyphlist (list glyphlist)))
+ (setq glyphlist (devanagari-normalize-narrow-glyph glyphlist))
+ (mapconcat '(lambda (x) (let ((char (get-char-code-property
+ x 'glyph-to-char)))
+ (if (null char) (char-to-string x) char)))
+ (devanagari-reorder-glyph-for-decomposition glyphlist)
+ "")))
+
+;;;###autoload
+(defun devanagari-decompose-string (str)
+ "This function Decomposes Devanagari glyph string to
+basic Devanagari character string."
+ (let ((src str) (dst ""))
+ (while (not (equal src ""))
+ (let* ((char (string-to-char src))
+ (clen (char-bytes char)))
+ (setq src (substring src clen))
+ (setq dst (concat dst
+ (devanagari-decompose-char char)))))
+ dst))
+
+;;;###autoload
+(defun devanagari-decompose-region (from to)
+ (interactive "r")
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (while (re-search-forward "." nil t)
+ (let* ((match-b (match-beginning 0)) (match-e (match-end 0))
+ (decmps (devanagari-decompose-string (buffer-substring match-b match-e))))
+ (delete-char -1)
+ (insert decmps)))))
+
+
+
+;; For pre-write and post-read conversion
+
+;;;###autoload
+(defun devanagari-compose-from-is13194-region (from to)
+ "Compose IS 13194 characters in the region to Devanagari characters."
+ (interactive "r")
+ (save-restriction
+ (narrow-to-region from to)
+ (indian-to-devanagari-region (point-min) (point-max))
+ (devanagari-compose-region (point-min) (point-max))))
+
+;;;###autoload
+(defun devanagari-decompose-to-is13194-region (from to)
+ "Decompose Devanagari characters in the region to IS 13194 characters."
+ (interactive "r")
+ (save-restriction
+ (narrow-to-region from to)
+ (devanagari-decompose-region (point-min) (point-max))
+ (devanagari-to-indian-region (point-min) (point-max))))
+
+;;
+(provide 'language/devan-util)
+
+;;; Local Variables:
+;;; generated-autoload-file: "../loaddefs.el"
+;;; End:
+;;; devan-util.el ends here
--- /dev/null
+;;; devanagari.el --- Support for Devanagari Languages
+
+;; Copyright (C) 1996 Free Software Foundation, Inc.
+
+;; Author: KAWABATA, Taichi <kawabata@is.s.u-tokyo.ac.jp>
+
+;; Keywords: multilingual, Indian, Devanagari
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; History:
+;; 1996.9.18 written by KAWABATA, Taichi <kawabata@is.s.u-tokyo.ac.jp>
+
+;;; Code:
+
+(make-coding-system
+ 'coding-system-is13194-devanagari 2 ?D
+ "Coding-system used for ASCII(MSB=0) & IS13194-Devanagari(MSB=1)."
+ '((ascii t) (indian-is13194 t) nil nil
+ nil ascii-eol))
+(put 'coding-system-is13194-devanagari
+ 'post-read-conversion 'devanagari-compose-from-is13194-region)
+(put 'coding-system-is13194-devanagari
+ 'pre-write-conversion 'devanagari-decompose-to-is13194-region)
+
+(register-input-method
+ "Devanagari" '("quail-devanagari-transliteration" quail-use-package
+ "quail/devanagari"))
+
+(register-input-method
+ "Devanagari" '("quail-devanagari-keyboard-a" quail-use-package
+ "quail/devanagari"))
+
+(register-input-method
+ "Devanagari" '("quail-devanagari-itrans" quail-use-package
+ "quail/devanagari"))
+
+(defun setup-devanagari-environment ()
+ (setq coding-category-iso-8-1 'coding-system-is13194-devanagari)
+
+ (set-coding-priority
+ '(coding-category-iso-7
+ coding-category-iso-8-1))
+
+ (setq-default buffer-file-coding-system 'coding-system-is13194-devanagari)
+
+ (setq default-input-method '("Devanagari" . "quail-devanagari-itrans"))
+ )
+
+(set-language-info-alist
+ "Devanagari" '((setup-function . setup-devanagari-environment)
+ (charset . (indian-is13194 indian-2-column indian-1-column))
+ (coding-system . (coding-system-is13194-devanagari))
+ (documentation . t)))
+
+(let ((deflist '(;; chars syntax category
+ ("\e$(5!!!"!#\e(B" "w" ?7) ; vowel-modifying diacritical mark
+ ; chandrabindu, anuswar, visarga
+ ("\e$(5!$\e(B-\e$(5!2\e(B" "w" ?5) ; independent vowel
+ ("\e$(5!3\e(B-\e$(5!X\e(B" "w" ?0) ; consonant
+ ("\e$(5!Z\e(B-\e$(5!g\e(B" "w" ?8) ; matra
+ ("\e$(5!q\e(B-\e$(5!z\e(B" "w" ?6) ; digit
+ ))
+ elm chars len syntax category to ch i)
+ (while deflist
+ (setq elm (car deflist))
+ (setq chars (car elm)
+ len (length chars)
+ syntax (nth 1 elm)
+ category (nth 2 elm)
+ i 0)
+ (while (< i len)
+ (if (= (aref chars i) ?-)
+ (setq i (1+ i)
+ to (sref chars i))
+ (setq ch (sref chars i)
+ to ch))
+ (while (<= ch to)
+ (modify-syntax-entry ch syntax)
+ (modify-category-entry ch category)
+ (setq ch (1+ ch)))
+ (setq i (+ i (char-bytes to))))
+ (setq deflist (cdr deflist))))
+
+;;
+;; Devanagari Glyph List
+;;
+;;2120 \e$(5!!!"!#!$!%!&!'!(!)!*!+!,!-!.!/\e(B
+;;2130 \e$(5!0!1!2!3!4!5!6!7!8!9!:!;!<!=!>!?\e(B
+;;2140 \e$(5!@!A!B!C!D!E!F!G!H!I!J!K!L!M!N!O\e(B
+;;2150 \e$(5!P!Q!R!S!T!U!V!W!X!Y!Z![!\!]!^!_\e(B
+;;2160 \e$(5!`!a!b!c!d!e!f!g!h!i!j!k!l!m!n!o\e(B
+;;2170 \e$(5!p!q!r!s!t!u!v!w!x!y!z!{!|!}!~\e(B
+;;
+;;2220 \e$(5"!"""#"$"%"&"'"(")"*"+","-"."/\e(B
+;;2230 \e$(5"0"1"2"3"4"5"6"7"8"9":";"<"=">"?\e(B
+;;2240 \e$(5"@"A"B"C"D"E"F"G"H"I"J"K"L"M"N"O\e(B
+;;2250 \e$(5"P"Q"R"S"T"U"V"W"X"Y"Z"["\"]"^"_\e(B
+;;2260 \e$(5"`"a"b"c"d"e"f"g"h"i"j"k"l"m"n"o\e(B
+;;2270 \e$(5"p"q"r"s"t"u"v"w"x"y"z"{"|"}"~\e(B
+;;
+;;2320 \e$(5#!#"###$#%#&#'#(#)#*#+#,#-#.#/\e(B
+;;2330 \e$(5#0#1#2#3#4#5#6#7#8#9#:#;#<#=#>#?\e(B
+;;2340 \e$(5#@#A#B#C#D#E#F#G#H#I#J#K#L#M#N#O\e(B
+;;2350 \e$(5#P#Q#R#S#T#U#V#W#X#Y#Z#[#\#]#^#_\e(B
+;;2360 \e$(5#`#a#b#c#d#e#f#g#h#i#j#k#l#m#n#o\e(B
+;;2370 \e$(5#p#q#r#s#t#u#v#w#x#y#z#{#|#}#~\e(B
+;;
+;;2420 \e$(5$!$"$#$$$%$&$'$($)$*$+$,$-$.$/\e(B
+;;2430 \e$(5$0$1$2$3$4$5$6$7$8$9$:$;$<$=$>$?\e(B
+;;2440 \e$(5$@$A$B$C$D$E$F$G$H$I$J$K$L$M$N$O\e(B
+;;2450 \e$(5$P$Q$R$S$T$U$V$W$X$Y$Z$[$\$]$^$_\e(B
+;;2460 \e$(5$`$a$b$c$d$e$f$g$h$i$j$k$l$m$n$o\e(B
+;;2470 \e$(5$p$q$r$s$t$u$v$w$x$y$z${$|$}$~\e(B
+;;
+;;2120 \e$(6!!!"!#!$!%!&!'!(!)!*!+!,!-!.!/\e(B
+;;2130 \e$(6!0!1!2!3!4!5!6!7!8!9!:!;!<!=!>!?\e(B
+;;2140 \e$(6!@!A!B!C!D!E!F!G!H!I!J!K!L!M!N!O\e(B
+;;2150 \e$(6!P!Q!R!S!T!U!V!W!X!Y!Z![!\!]!^!_\e(B
+;;2160 \e$(6!`!a!b!c!d!e!f!g!h!i!j!k!l!m!n!o\e(B
+;;2170 \e$(6!p!q!r!s!t!u!v!w!x!y!z!{!|!}!~\e(B
+;;
+;;2220 \e$(6"!"""#"$"%"&"'"(")"*"+","-"."/\e(B
+;;2230 \e$(6"0"1"2"3"4"5"6"7"8"9":";"<"=">"?\e(B
+;;2240 \e$(6"@"A"B"C"D"E"F"G"H"I"J"K"L"M"N"O\e(B
+;;2250 \e$(6"P"Q"R"S"T"U"V"W"X"Y"Z"["\"]"^"_\e(B
+;;2260 \e$(6"`"a"b"c"d"e"f"g"h"i"j"k"l"m"n"o\e(B
+;;2270 \e$(6"p"q"r"s"t"u"v"w"x"y"z"{"|"}"~\e(B
+;;2320 \e$(6#!#"###$#%#&#'#(#)#*#+#,#-#.#/\e(B
+;;2330 \e$(6#0#1#2#3#4#5#6#7#8#9#:#;#<#=#>#?\e(B
+;;2340 \e$(6#@#A#B#C#D#E#F#G#H#I#J#K#L#M#N#O\e(B
+;;2350 \e$(6#P#Q#R#S#T#U#V#W#X#Y#Z#[#\#]#^#_\e(B
+;;2360 \e$(6#`#a#b#c#d#e#f#g#h#i#j#k#l#m#n#o\e(B
+;;2370 \e$(6#p#q#r#s#t#u#v#w#x#y#z#{#|#}#~\e(B
+;;
+;;2320 \e$(6$!$"$#$$$%$&$'$($)$*$+$,$-$.$/\e(B
+;;2430 \e$(6$0$1$2$3$4$5$6$7$8$9$:$;$<$=$>$?\e(B
+;;2440 \e$(6$@$A$B$C$D$E$F$G$H$I$J$K$L$M$N$O\e(B
+;;2450 \e$(6$P$Q$R$S$T$U$V$W$X$Y$Z$[$\$]$^$_\e(B
+;;2460 \e$(6$`$a$b$c$d$e$f$g$h$i$j$k$l$m$n$o\e(B
+;;2470 \e$(6$p$q$r$s$t$u$v$w$x$y$z${$|$}$~\e(B
+;;
+;;
+;; Modify the following table if you change the set of 1-column font.
+;;
+(defconst devanagari-1-column-char
+ '((?\e$(5!!\e(B . ?\e$(6!!\e(B)
+ (?\e$(5!"\e(B . ?\e$(6!"\e(B)
+ (?\e$(5!#\e(B . ?\e$(6!#\e(B)
+ (?\e$(5!$\e(B . nil)
+ (?\e$(5!%\e(B . nil)
+ (?\e$(5!&\e(B . ?\e$(6!&\e(B)
+ (?\e$(5!'\e(B . ?\e$(6!'\e(B)
+ (?\e$(5!(\e(B . ?\e$(6!(\e(B)
+ (?\e$(5!)\e(B . nil)
+ (?\e$(5!*\e(B . nil)
+ (?\e$(5!+\e(B . nil)
+ (?\e$(5!,\e(B . nil)
+ (?\e$(5!-\e(B . nil)
+ (?\e$(5!.\e(B . nil)
+ (?\e$(5!/\e(B . nil)
+ (?\e$(5!0\e(B . nil)
+ (?\e$(5!1\e(B . nil)
+ (?\e$(5!2\e(B . nil)
+ (?\e$(5!3\e(B . nil)
+ (?\e$(5!4\e(B . nil)
+ (?\e$(5!5\e(B . ?\e$(6!5\e(B)
+ (?\e$(5!6\e(B . nil)
+ (?\e$(5!7\e(B . nil)
+ (?\e$(5!8\e(B . nil)
+ (?\e$(5!9\e(B . nil)
+ (?\e$(5!:\e(B . nil)
+ (?\e$(5!;\e(B . nil)
+ (?\e$(5!<\e(B . nil)
+ (?\e$(5!=\e(B . ?\e$(6!=\e(B)
+ (?\e$(5!>\e(B . ?\e$(6!>\e(B)
+ (?\e$(5!?\e(B . ?\e$(6!?\e(B)
+ (?\e$(5!@\e(B . ?\e$(6!@\e(B)
+ (?\e$(5!A\e(B . nil)
+ (?\e$(5!B\e(B . ?\e$(6!B\e(B)
+ (?\e$(5!C\e(B . ?\e$(6!C\e(B)
+ (?\e$(5!D\e(B . ?\e$(6!D\e(B)
+ (?\e$(5!E\e(B . ?\e$(6!E\e(B)
+ (?\e$(5!F\e(B . ?\e$(6!F\e(B)
+ (?\e$(5!G\e(B . ?\e$(6!G\e(B)
+ (?\e$(5!H\e(B . ?\e$(6!H\e(B)
+ (?\e$(5!I\e(B . nil)
+ (?\e$(5!J\e(B . ?\e$(6!J\e(B)
+ (?\e$(5!K\e(B . ?\e$(6!K\e(B)
+ (?\e$(5!L\e(B . ?\e$(6!L\e(B)
+ (?\e$(5!M\e(B . ?\e$(6!M\e(B)
+ (?\e$(5!N\e(B . ?\e$(6!N\e(B)
+ (?\e$(5!O\e(B . ?\e$(6!O\e(B)
+ (?\e$(5!P\e(B . ?\e$(6!P\e(B)
+ (?\e$(5!Q\e(B . nil)
+ (?\e$(5!R\e(B . nil)
+ (?\e$(5!S\e(B . nil)
+ (?\e$(5!T\e(B . ?\e$(6!T\e(B)
+ (?\e$(5!U\e(B . nil)
+ (?\e$(5!V\e(B . ?\e$(6!V\e(B)
+ (?\e$(5!W\e(B . ?\e$(6!W\e(B)
+ (?\e$(5!X\e(B . ?\e$(6!X\e(B)
+ (?\e$(5!Y\e(B . nil)
+ (?\e$(5!Z\e(B . ?\e$(6!Z\e(B)
+ (?\e$(5![\e(B . ?\e$(6![\e(B)
+ (?\e$(5!\\e(B . ?\e$(6!\\e(B)
+ (?\e$(5!]\e(B . ?\e$(6!]\e(B)
+ (?\e$(5!^\e(B . ?\e$(6!^\e(B)
+ (?\e$(5!_\e(B . ?\e$(6!_\e(B)
+ (?\e$(5!`\e(B . ?\e$(6!`\e(B)
+ (?\e$(5!a\e(B . ?\e$(6!a\e(B)
+ (?\e$(5!b\e(B . ?\e$(6!b\e(B)
+ (?\e$(5!c\e(B . ?\e$(6!c\e(B)
+ (?\e$(5!d\e(B . ?\e$(6!d\e(B)
+ (?\e$(5!e\e(B . ?\e$(6!e\e(B)
+ (?\e$(5!f\e(B . ?\e$(6!f\e(B)
+ (?\e$(5!g\e(B . ?\e$(6!g\e(B)
+ (?\e$(5!h\e(B . ?\e$(6!h\e(B)
+ (?\e$(5!i\e(B . ?\e$(6!i\e(B)
+ (?\e$(5!j\e(B . ?\e$(6!j\e(B)
+ (nil . nil)
+ (nil . nil)
+ (nil . nil)
+ (nil . nil)
+ (nil . nil)
+ (nil . nil)
+ (?\e$(5!q\e(B . ?\e$(6!q\e(B)
+ (?\e$(5!r\e(B . ?\e$(6!r\e(B)
+ (?\e$(5!s\e(B . ?\e$(6!s\e(B)
+ (?\e$(5!t\e(B . ?\e$(6!t\e(B)
+ (?\e$(5!u\e(B . ?\e$(6!u\e(B)
+ (?\e$(5!v\e(B . ?\e$(6!v\e(B)
+ (?\e$(5!w\e(B . ?\e$(6!w\e(B)
+ (?\e$(5!x\e(B . ?\e$(6!x\e(B)
+ (?\e$(5!y\e(B . ?\e$(6!y\e(B)
+ (?\e$(5!z\e(B . ?\e$(6!z\e(B)
+ (nil . nil)
+ (nil . nil)
+ (nil . nil)
+ (nil . nil)
+ (?\e$(5"!\e(B . nil)
+ (?\e$(5""\e(B . nil)
+ (?\e$(5"#\e(B . nil)
+ (?\e$(5"$\e(B . nil)
+ (?\e$(5"%\e(B . ?\e$(6"%\e(B)
+ (?\e$(5"&\e(B . ?\e$(6"&\e(B)
+ (?\e$(5"'\e(B . nil)
+ (?\e$(5"(\e(B . nil)
+ (?\e$(5")\e(B . nil)
+ (?\e$(5"*\e(B . nil)
+ (?\e$(5"+\e(B . nil)
+ (?\e$(5",\e(B . ?\e$(6",\e(B)
+ (?\e$(5"-\e(B . nil)
+ (?\e$(5".\e(B . ?\e$(6".\e(B)
+ (?\e$(5"/\e(B . nil)
+ (?\e$(5"0\e(B . nil)
+ (?\e$(5"1\e(B . nil)
+ (?\e$(5"2\e(B . nil)
+ (?\e$(5"3\e(B . ?\e$(6"3\e(B)
+ (?\e$(5"4\e(B . ?\e$(6"4\e(B)
+ (?\e$(5"5\e(B . ?\e$(6"5\e(B)
+ (?\e$(5"6\e(B . ?\e$(6"6\e(B)
+ (?\e$(5"7\e(B . nil)
+ (?\e$(5"8\e(B . ?\e$(6"8\e(B)
+ (?\e$(5"9\e(B . nil)
+ (?\e$(5":\e(B . ?\e$(6":\e(B)
+ (?\e$(5";\e(B . ?\e$(6";\e(B)
+ (?\e$(5"<\e(B . ?\e$(6"<\e(B)
+ (?\e$(5"=\e(B . nil)
+ (?\e$(5">\e(B . nil)
+ (?\e$(5"?\e(B . nil)
+ (?\e$(5"@\e(B . nil)
+ (?\e$(5"A\e(B . ?\e$(6"A\e(B)
+ (?\e$(5"B\e(B . ?\e$(6"B\e(B)
+ (?\e$(5"C\e(B . ?\e$(6"C\e(B)
+ (?\e$(5"D\e(B . nil)
+ (?\e$(5"E\e(B . ?\e$(6"E\e(B)
+ (?\e$(5"F\e(B . ?\e$(6"F\e(B)
+ (?\e$(5"G\e(B . ?\e$(6"G\e(B)
+ (?\e$(5"H\e(B . ?\e$(6"H\e(B)
+ (?\e$(5"I\e(B . ?\e$(6"I\e(B)
+ (?\e$(5"J\e(B . ?\e$(6"J\e(B)
+ (?\e$(5"K\e(B . ?\e$(6"K\e(B)
+ (?\e$(5"L\e(B . ?\e$(6"L\e(B)
+ (?\e$(5"M\e(B . ?\e$(6"M\e(B)
+ (?\e$(5"N\e(B . ?\e$(6"N\e(B)
+ (?\e$(5"O\e(B . nil)
+ (?\e$(5"P\e(B . nil)
+ (?\e$(5"Q\e(B . ?\e$(6"Q\e(B)
+ (?\e$(5"R\e(B . nil)
+ (?\e$(5"S\e(B . nil)
+ (?\e$(5"T\e(B . ?\e$(6"T\e(B)
+ (?\e$(5"U\e(B . ?\e$(6"U\e(B)
+ (?\e$(5"V\e(B . ?\e$(6"V\e(B)
+ (?\e$(5"W\e(B . ?\e$(6"W\e(B)
+ (?\e$(5"X\e(B . nil)
+ (?\e$(5"Y\e(B . nil)
+ (?\e$(5"Z\e(B . nil)
+ (?\e$(5"[\e(B . nil)
+ (?\e$(5"\\e(B . nil)
+ (?\e$(5"]\e(B . nil)
+ (?\e$(5"^\e(B . nil)
+ (?\e$(5"_\e(B . nil)
+ (?\e$(5"`\e(B . ?\e$(6"`\e(B)
+ (?\e$(5"a\e(B . ?\e$(6"a\e(B)
+ (?\e$(5"b\e(B . ?\e$(6"b\e(B)
+ (?\e$(5"c\e(B . ?\e$(6"c\e(B)
+ (?\e$(5"d\e(B . ?\e$(6"d\e(B)
+ (?\e$(5"e\e(B . ?\e$(6"e\e(B)
+ (?\e$(5"f\e(B . ?\e$(6"f\e(B)
+ (?\e$(5"g\e(B . ?\e$(6"g\e(B)
+ (?\e$(5"h\e(B . ?\e$(6"h\e(B)
+ (?\e$(5"i\e(B . ?\e$(6"i\e(B)
+ (?\e$(5"j\e(B . ?\e$(6"j\e(B)
+ (?\e$(5"k\e(B . nil)
+ (?\e$(5"l\e(B . ?\e$(6"l\e(B)
+ (?\e$(5"m\e(B . ?\e$(6"m\e(B)
+ (?\e$(5"n\e(B . nil)
+ (?\e$(5"o\e(B . nil)
+ (?\e$(5"p\e(B . ?\e$(6"p\e(B)
+ (?\e$(5"q\e(B . ?\e$(6"q\e(B)
+ (?\e$(5"r\e(B . ?\e$(6"r\e(B)
+ (?\e$(5"s\e(B . ?\e$(6"s\e(B)
+ (?\e$(5"t\e(B . ?\e$(6"t\e(B)
+ (?\e$(5"u\e(B . ?\e$(6"u\e(B)
+ (?\e$(5"v\e(B . nil)
+ (?\e$(5"w\e(B . nil)
+ (?\e$(5"x\e(B . nil)
+ (?\e$(5"y\e(B . ?\e$(6"y\e(B)
+ (?\e$(5"z\e(B . ?\e$(6"z\e(B)
+ (?\e$(5"{\e(B . nil)
+ (?\e$(5"|\e(B . nil)
+ (?\e$(5"}\e(B . nil)
+ (?\e$(5"~\e(B . nil)
+ (?\e$(5#!\e(B . nil)
+ (?\e$(5#"\e(B . nil)
+ (?\e$(5##\e(B . nil)
+ (?\e$(5#$\e(B . nil)
+ (?\e$(5#%\e(B . nil)
+ (?\e$(5#&\e(B . ?\e$(6#&\e(B)
+ (?\e$(5#'\e(B . ?\e$(6#'\e(B)
+ (?\e$(5#(\e(B . nil)
+ (?\e$(5#)\e(B . nil)
+ (?\e$(5#*\e(B . ?\e$(6#*\e(B)
+ (?\e$(5#+\e(B . nil)
+ (?\e$(5#,\e(B . nil)
+ (?\e$(5#-\e(B . nil)
+ (?\e$(5#.\e(B . nil)
+ (?\e$(5#/\e(B . nil)
+ (?\e$(5#0\e(B . nil)
+ (?\e$(5#1\e(B . nil)
+ (?\e$(5#2\e(B . nil)
+ (?\e$(5#3\e(B . nil)
+ (?\e$(5#4\e(B . nil)
+ (?\e$(5#5\e(B . ?\e$(6#5\e(B)
+ (?\e$(5#6\e(B . nil)
+ (?\e$(5#7\e(B . nil)
+ (?\e$(5#8\e(B . nil)
+ (?\e$(5#9\e(B . nil)
+ (?\e$(5#:\e(B . nil)
+ (?\e$(5#;\e(B . nil)
+ (?\e$(5#<\e(B . nil)
+ (?\e$(5#=\e(B . nil)
+ (?\e$(5#>\e(B . nil)
+ (?\e$(5#?\e(B . ?\e$(6#?\e(B)
+ (?\e$(5#@\e(B . ?\e$(6#@\e(B)
+ (?\e$(5#A\e(B . nil)
+ (?\e$(5#B\e(B . nil)
+ (?\e$(5#C\e(B . nil)
+ (?\e$(5#D\e(B . nil)
+ (?\e$(5#E\e(B . nil)
+ (?\e$(5#F\e(B . nil)
+ (?\e$(5#G\e(B . nil)
+ (?\e$(5#H\e(B . nil)
+ (?\e$(5#I\e(B . nil)
+ (?\e$(5#J\e(B . ?\e$(6#J\e(B)
+ (?\e$(5#K\e(B . nil)
+ (?\e$(5#L\e(B . nil)
+ (?\e$(5#M\e(B . nil)
+ (?\e$(5#N\e(B . nil)
+ (?\e$(5#O\e(B . nil)
+ (?\e$(5#P\e(B . nil)
+ (?\e$(5#Q\e(B . nil)
+ (?\e$(5#R\e(B . ?\e$(6#R\e(B)
+ (?\e$(5#S\e(B . nil)
+ (?\e$(5#T\e(B . nil)
+ (?\e$(5#U\e(B . nil)
+ (?\e$(5#V\e(B . nil)
+ (?\e$(5#W\e(B . nil)
+ (?\e$(5#X\e(B . nil)
+ (?\e$(5#Y\e(B . nil)
+ (?\e$(5#Z\e(B . nil)
+ (?\e$(5#[\e(B . nil)
+ (?\e$(5#\\e(B . nil)
+ (?\e$(5#]\e(B . nil)
+ (?\e$(5#^\e(B . nil)
+ (?\e$(5#_\e(B . nil)
+ (?\e$(5#`\e(B . nil)
+ (?\e$(5#a\e(B . ?\e$(6#a\e(B)
+ (?\e$(5#b\e(B . ?\e$(6#b\e(B)
+ (?\e$(5#c\e(B . nil)
+ (?\e$(5#d\e(B . nil)
+ (?\e$(5#e\e(B . nil)
+ (?\e$(5#f\e(B . nil)
+ (?\e$(5#g\e(B . nil)
+ (?\e$(5#h\e(B . nil)
+ (?\e$(5#i\e(B . nil)
+ (?\e$(5#j\e(B . ?\e$(6#j\e(B)
+ (?\e$(5#k\e(B . ?\e$(6#k\e(B)
+ (?\e$(5#l\e(B . ?\e$(6#l\e(B)
+ (?\e$(5#m\e(B . nil)
+ (?\e$(5#n\e(B . nil)
+ (?\e$(5#o\e(B . nil)
+ (?\e$(5#p\e(B . nil)
+ (?\e$(5#q\e(B . nil)
+ (?\e$(5#r\e(B . nil)
+ (?\e$(5#s\e(B . nil)
+ (?\e$(5#t\e(B . nil)
+ (?\e$(5#u\e(B . nil)
+ (?\e$(5#v\e(B . nil)
+ (?\e$(5#w\e(B . nil)
+ (?\e$(5#x\e(B . nil)
+ (?\e$(5#y\e(B . nil)
+ (?\e$(5#z\e(B . nil)
+ (?\e$(5#{\e(B . nil)
+ (?\e$(5#|\e(B . nil)
+ (?\e$(5#}\e(B . nil)
+ (?\e$(5#~\e(B . nil)
+ (?\e$(5$!\e(B . nil)
+ (?\e$(5$"\e(B . nil)
+ (?\e$(5$#\e(B . nil)
+ (?\e$(5$$\e(B . nil)
+ (?\e$(5$%\e(B . nil)
+ (?\e$(5$&\e(B . nil)
+ (?\e$(5$'\e(B . nil)
+ (?\e$(5$(\e(B . nil)
+ (?\e$(5$)\e(B . nil)
+ (?\e$(5$*\e(B . nil)
+ (?\e$(5$+\e(B . nil)
+ (?\e$(5$,\e(B . nil)
+ (?\e$(5$-\e(B . nil)
+ (?\e$(5$.\e(B . nil)
+ (?\e$(5$/\e(B . nil)
+ (?\e$(5$0\e(B . nil)
+ (?\e$(5$1\e(B . nil)
+ (?\e$(5$2\e(B . nil)
+ (?\e$(5$3\e(B . nil)
+ (?\e$(5$4\e(B . nil)
+ (?\e$(5$5\e(B . nil)
+ (?\e$(5$6\e(B . nil)
+ (?\e$(5$7\e(B . nil)
+ (?\e$(5$8\e(B . nil)
+ (?\e$(5$9\e(B . nil)
+ (?\e$(5$:\e(B . nil)
+ (?\e$(5$;\e(B . nil)
+ (?\e$(5$<\e(B . nil)
+ (?\e$(5$=\e(B . nil)
+ (?\e$(5$>\e(B . nil)
+ (?\e$(5$?\e(B . nil)
+ (?\e$(5$@\e(B . nil)
+ (?\e$(5$A\e(B . ?\e$(6$A\e(B)
+ (?\e$(5$B\e(B . nil)
+ (?\e$(5$C\e(B . nil)
+ (?\e$(5$D\e(B . nil)
+ (?\e$(5$E\e(B . ?\e$(6$E\e(B)
+ (?\e$(5$F\e(B . nil)
+ (?\e$(5$G\e(B . nil)
+ (?\e$(5$H\e(B . ?\e$(6$H\e(B)
+ (?\e$(5$I\e(B . ?\e$(6$I\e(B)
+ (?\e$(5$J\e(B . ?\e$(6$J\e(B)
+ (?\e$(5$K\e(B . nil)
+ (?\e$(5$L\e(B . nil)
+ (?\e$(5$M\e(B . nil)
+ (?\e$(5$N\e(B . ?\e$(6$N\e(B)
+ (?\e$(5$O\e(B . nil)
+ (?\e$(5$P\e(B . ?\e$(6$P\e(B)
+ (?\e$(5$Q\e(B . ?\e$(6$Q\e(B)
+ (?\e$(5$R\e(B . ?\e$(6$R\e(B)
+ (?\e$(5$S\e(B . nil)
+ (?\e$(5$T\e(B . nil)
+ (?\e$(5$U\e(B . nil)
+ (?\e$(5$V\e(B . nil)
+ (?\e$(5$W\e(B . nil)
+ (?\e$(5$X\e(B . nil)
+ (?\e$(5$Y\e(B . nil)
+ (?\e$(5$Z\e(B . nil)
+ (?\e$(5$[\e(B . nil)
+ (?\e$(5$\\e(B . nil)
+ (?\e$(5$]\e(B . nil)
+ (?\e$(5$^\e(B . nil)
+ (?\e$(5$_\e(B . nil)
+ (?\e$(5$`\e(B . nil)
+ (?\e$(5$a\e(B . nil)
+ (?\e$(5$b\e(B . nil)
+ (?\e$(5$c\e(B . nil)
+ (?\e$(5$d\e(B . nil)
+ (?\e$(5$e\e(B . nil)
+ (?\e$(5$f\e(B . nil)
+ (?\e$(5$g\e(B . nil)
+ (?\e$(5$h\e(B . ?\e$(6$h\e(B)
+ (?\e$(5$i\e(B . ?\e$(6$i\e(B)
+ (?\e$(5$j\e(B . ?\e$(6$j\e(B)
+ (?\e$(5$k\e(B . nil)
+ (?\e$(5$l\e(B . ?\e$(6$l\e(B)
+ (?\e$(5$m\e(B . ?\e$(6$m\e(B)
+ (?\e$(5$n\e(B . ?\e$(6$n\e(B)
+ (?\e$(5$o\e(B . nil)
+ (?\e$(5$p\e(B . ?\e$(6$p\e(B)
+ (?\e$(5$q\e(B . ?\e$(6$q\e(B)
+ (?\e$(5$r\e(B . ?\e$(6$r\e(B)
+ (?\e$(5$s\e(B . nil)
+ (?\e$(5$t\e(B . nil)
+ (?\e$(5$u\e(B . ?\e$(6$u\e(B)
+ (?\e$(5$v\e(B . ?\e$(6$v\e(B)
+ (?\e$(5$w\e(B . nil)
+ (?\e$(5$x\e(B . ?\e$(6$x\e(B)
+ (?\e$(5$y\e(B . ?\e$(6$y\e(B)
+ (?\e$(5$z\e(B . nil)
+ (?\e$(5${\e(B . nil)
+ (?\e$(5$|\e(B . nil)
+ (?\e$(5$}\e(B . nil)
+ (?\e$(5$~\e(B . nil)
+ ))
+
+;;; devanagari.el ends here
--- /dev/null
+;; ethio-util.el -- utilities for Ethiopic
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: mule, multilingual, Chinese
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Code:
+
+;;
+;; ETHIOPIC UTILITY FUNCTIONS
+;;
+
+;; To automatically convert Ethiopic text to SERA format when sending mail,
+;; (add-hook 'mail-send-hook 'fidel-to-sera-mail)
+;;
+;; To automatically convert SERA format to Ethiopic when receiving mail,
+;; (add-hook 'rmail-show-message-hook 'sera-to-fidel-mail)
+;;
+;; To automatically convert Ethiopic text to SERA format when posting news,
+;; (add-hook 'news-inews-hook 'fidel-to-sera-mail)
+;;
+;; If the filename ends in ".sera", editing will be done in fidel
+;; while file I/O will be done in sera.
+
+;;
+;; SERA to FIDEL
+;;
+
+(defconst sera-to-fidel-table
+ [
+ nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+ nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+;;; SP ! " # $ % & ' ( ) * + , - . /
+ nil nil nil nil nil nil nil ("") nil nil nil nil ("\e$(2$Q\e(B") nil ("\e$(2$P\e(B") nil
+;;; 0 1 2 3 4 5 6 7 8 9 : ; < = > ? @
+ nil nil nil nil nil nil nil nil nil nil ("\e$(2$S\e(B") ("\e$(2$R\e(B") nil nil nil nil nil
+;;; A
+ ("\e$(2"V\e(B" (?2 "\e$(2#b\e(B"))
+;;; B
+ ("\e$(2!F\e(B" (?e "\e$(2!A\e(B") (?u "\e$(2!B\e(B") (?i "\e$(2!C\e(B") (?a "\e$(2!D\e(B") (?E "\e$(2!E\e(B") (?o "\e$(2!G\e(B") (?| "\e$(2!F\e(B")
+ (?W "\e$(2!H\e(B" (?a "\e$(2!H\e(B")
+ (?e "\e$(2!F#L\e(B") (?u "\e$(2!F#M\e(B") (?i "\e$(2!F#N\e(B") (?E "\e$(2!F#P\e(B") (?' "\e$(2!F#M\e(B")))
+;;; C
+ ("\e$(2"8\e(B" (?e "\e$(2"3\e(B") (?u "\e$(2"4\e(B") (?i "\e$(2"5\e(B") (?a "\e$(2"6\e(B") (?E "\e$(2"7\e(B") (?o "\e$(2"9\e(B") (?| "\e$(2"8\e(B")
+ (?W "\e$(2":\e(B" (?a "\e$(2":\e(B")
+ (?e "\e$(2"8#L\e(B") (?u "\e$(2"8#M\e(B") (?i "\e$(2"8#N\e(B") (?E "\e$(2"8#P\e(B") (?' "\e$(2"8#M\e(B")))
+;;; D
+ ("\e$(2$0\e(B" (?e "\e$(2$+\e(B") (?u "\e$(2$,\e(B") (?i "\e$(2$-\e(B") (?a "\e$(2$.\e(B") (?E "\e$(2$/\e(B") (?o "\e$(2$1\e(B") (?| "\e$(2$0\e(B"))
+;;; E
+ ("\e$(2"W\e(B" (?2 "\e$(2#c\e(B"))
+;;; F
+ ("\e$(2"@\e(B" (?e "\e$(2";\e(B") (?u "\e$(2"<\e(B") (?i "\e$(2"=\e(B") (?a "\e$(2">\e(B") (?E "\e$(2"?\e(B") (?o "\e$(2"A\e(B") (?| "\e$(2"@\e(B")
+ (?W "\e$(2"B\e(B" (?a "\e$(2"B\e(B")
+ (?e "\e$(2"@#L\e(B") (?u "\e$(2"@#M\e(B") (?i "\e$(2"@#N\e(B") (?E "\e$(2"@#P\e(B") (?' "\e$(2"@#M\e(B")))
+;;; G
+ ("\e$(2$>\e(B" (?e "\e$(2$9\e(B") (?u "\e$(2$:\e(B") (?i "\e$(2$;\e(B") (?a "\e$(2$<\e(B") (?E "\e$(2$=\e(B") (?o "\e$(2$?\e(B") (?| "\e$(2$>\e(B"))
+;;; H
+ ("\e$(2$"\e(B" (?e "\e$(2#{\e(B") (?u "\e$(2#|\e(B") (?i "\e$(2#}\e(B") (?a "\e$(2#~\e(B") (?E "\e$(2$!\e(B") (?o "\e$(2$#\e(B") (?| "\e$(2$"\e(B"))
+;;; I
+ ("\e$(2"X\e(B" (?2 "\e$(2#d\e(B"))
+;;; J
+ ("\e$(2$7\e(B" (?e "\e$(2$2\e(B") (?u "\e$(2$3\e(B") (?i "\e$(2$4\e(B") (?a "\e$(2$5\e(B") (?E "\e$(2$6\e(B") (?o "\e$(2$8\e(B") (?| "\e$(2$7\e(B"))
+;;; K
+ ("\e$(2"x\e(B" (?e "\e$(2"s\e(B") (?u "\e$(2"t\e(B") (?i "\e$(2"u\e(B") (?a "\e$(2"v\e(B") (?E "\e$(2"w\e(B") (?o "\e$(2"y\e(B") (?| "\e$(2"x\e(B")
+ (?W "\e$(2"{\e(B" (?e "\e$(2"z\e(B") (?u "\e$(2"{\e(B") (?i "\e$(2"|\e(B") (?a "\e$(2"}\e(B") (?E "\e$(2"~\e(B")))
+;;; L
+ ("\e$(2!&\e(B" (?e "\e$(2!!\e(B") (?u "\e$(2!"\e(B") (?i "\e$(2!#\e(B") (?a "\e$(2!$\e(B") (?E "\e$(2!%\e(B") (?o "\e$(2!'\e(B") (?| "\e$(2!&\e(B")
+ (?W "\e$(2!(\e(B" (?a "\e$(2!(\e(B")
+ (?e "\e$(2!&#L\e(B") (?u "\e$(2!&#M\e(B") (?i "\e$(2!&#N\e(B") (?E "\e$(2!&#P\e(B") (?' "\e$(2!&#M\e(B")))
+;;; M
+ ("\e$(2!.\e(B" (?e "\e$(2!)\e(B") (?u "\e$(2!*\e(B") (?i "\e$(2!+\e(B") (?a "\e$(2!,\e(B") (?E "\e$(2!-\e(B") (?o "\e$(2!/\e(B") (?| "\e$(2!.\e(B")
+ (?W "\e$(2!0\e(B" (?a "\e$(2!0\e(B")
+ (?e "\e$(2!.#L\e(B") (?u "\e$(2!.#M\e(B") (?i "\e$(2!.#N\e(B") (?E "\e$(2!.#P\e(B") (?' "\e$(2!.#M\e(B")))
+;;; N
+ ("\e$(2!n\e(B" (?e "\e$(2!i\e(B") (?u "\e$(2!j\e(B") (?i "\e$(2!k\e(B") (?a "\e$(2!l\e(B") (?E "\e$(2!m\e(B") (?o "\e$(2!o\e(B") (?| "\e$(2!n\e(B")
+ (?W "\e$(2!p\e(B" (?a "\e$(2!p\e(B")
+ (?e "\e$(2!n#L\e(B") (?u "\e$(2!n#M\e(B") (?i "\e$(2!n#N\e(B") (?E "\e$(2!n#P\e(B") (?' "\e$(2!n#M\e(B")))
+;;; O
+ ("\e$(2"Y\e(B" (?2 "\e$(2#e\e(B"))
+;;; P
+ ("\e$(2$E\e(B" (?e "\e$(2$@\e(B") (?u "\e$(2$A\e(B") (?i "\e$(2$B\e(B") (?a "\e$(2$C\e(B") (?E "\e$(2$D\e(B") (?o "\e$(2$F\e(B") (?| "\e$(2$E\e(B"))
+;;; Q
+ ("\e$(2#2\e(B" (?e "\e$(2#-\e(B") (?u "\e$(2#.\e(B") (?i "\e$(2#/\e(B") (?a "\e$(2#0\e(B") (?E "\e$(2#1\e(B") (?o "\e$(2#3\e(B") (?| "\e$(2#2\e(B")
+ (?W "\e$(2#5\e(B" (?e "\e$(2#4\e(B") (?u "\e$(2#5\e(B") (?i "\e$(2#6\e(B") (?a "\e$(2#7\e(B") (?E "\e$(2#8\e(B")))
+;;; R
+ ("\e$(2!6\e(B" (?e "\e$(2!1\e(B") (?u "\e$(2!2\e(B") (?i "\e$(2!3\e(B") (?a "\e$(2!4\e(B") (?E "\e$(2!5\e(B") (?o "\e$(2!7\e(B") (?| "\e$(2!6\e(B")
+ (?W "\e$(2!8\e(B" (?a "\e$(2!8\e(B")
+ (?e "\e$(2!6#L\e(B") (?u "\e$(2!6#M\e(B") (?i "\e$(2!6#N\e(B") (?E "\e$(2!6#P\e(B") (?' "\e$(2!6#M\e(B")))
+;;; S
+ ("\e$(2"P\e(B" (?e "\e$(2"K\e(B") (?u "\e$(2"L\e(B") (?i "\e$(2"M\e(B") (?a "\e$(2"N\e(B") (?E "\e$(2"O\e(B") (?o "\e$(2"Q\e(B") (?| "\e$(2"P\e(B")
+ (?W "\e$(2"R\e(B" (?a "\e$(2"R\e(B")
+ (?e "\e$(2"P#L\e(B") (?u "\e$(2"P#M\e(B") (?i "\e$(2"P#N\e(B") (?E "\e$(2"P#P\e(B") (?' "\e$(2"P#M\e(B"))
+ (?2 "\e$(2#]\e(B" (?| "\e$(2#]\e(B")
+ (?e "\e$(2#X\e(B") (?u "\e$(2#Y\e(B") (?i "\e$(2#Z\e(B") (?a "\e$(2#[\e(B") (?E "\e$(2#\\e(B") (?o "\e$(2#^\e(B")
+ (?W "\e$(2"R\e(B"
+ (?a "\e$(2"R\e(B")
+ (?e "\e$(2#]#L\e(B") (?u "\e$(2#]#M\e(B") (?i "\e$(2#]#N\e(B") (?E "\e$(2#]#P\e(B") (?' "\e$(2#]#M\e(B"))))
+
+;;; T
+ ("\e$(2"0\e(B" (?e "\e$(2"+\e(B") (?u "\e$(2",\e(B") (?i "\e$(2"-\e(B") (?a "\e$(2".\e(B") (?E "\e$(2"/\e(B") (?o "\e$(2"1\e(B") (?| "\e$(2"0\e(B")
+ (?W "\e$(2"2\e(B" (?a "\e$(2"2\e(B")
+ (?e "\e$(2"0#L\e(B") (?u "\e$(2"0#M\e(B") (?i "\e$(2"0#N\e(B") (?E "\e$(2"0#P\e(B") (?' "\e$(2"0#M\e(B")))
+;;; U
+ ("\e$(2"T\e(B" (?2 "\e$(2#`\e(B"))
+;;; V
+ ("\e$(2!N\e(B" (?e "\e$(2!I\e(B") (?u "\e$(2!J\e(B") (?i "\e$(2!K\e(B") (?a "\e$(2!L\e(B") (?E "\e$(2!M\e(B") (?o "\e$(2!O\e(B") (?| "\e$(2!N\e(B")
+ (?W "\e$(2!P\e(B" (?a "\e$(2!P\e(B")
+ (?e "\e$(2!N#L\e(B") (?u "\e$(2!N#M\e(B") (?i "\e$(2!N#N\e(B") (?E "\e$(2!N#P\e(B") (?' "\e$(2!N#M\e(B")))
+;;; W
+ ("\e$(2#M\e(B" (?e "\e$(2#L\e(B") (?u "\e$(2#M\e(B") (?i "\e$(2#N\e(B") (?a "\e$(2#O\e(B") (?E "\e$(2#P\e(B"))
+;;; X
+ ("\e$(2#y\e(B" (?e "\e$(2#t\e(B") (?u "\e$(2#u\e(B") (?i "\e$(2#v\e(B") (?a "\e$(2#w\e(B") (?E "\e$(2#x\e(B") (?o "\e$(2#z\e(B") (?| "\e$(2#y\e(B"))
+;;; Y
+ ("\e$(2$)\e(B" (?e "\e$(2$$\e(B") (?u "\e$(2$%\e(B") (?i "\e$(2$&\e(B") (?a "\e$(2$'\e(B") (?E "\e$(2$(\e(B") (?o "\e$(2$*\e(B") (?| "\e$(2$)\e(B"))
+;;; Z
+ ("\e$(2!~\e(B" (?e "\e$(2!y\e(B") (?u "\e$(2!z\e(B") (?i "\e$(2!{\e(B") (?a "\e$(2!|\e(B") (?E "\e$(2!}\e(B") (?o "\e$(2"!\e(B") (?| "\e$(2!~\e(B")
+ (?W "\e$(2""\e(B" (?a "\e$(2""\e(B")
+ (?e "\e$(2!~#L\e(B") (?u "\e$(2!~#M\e(B") (?i "\e$(2!~#N\e(B") (?E "\e$(2!~#P\e(B") (?' "\e$(2!~#M\e(B")))
+;;; [ \ ] ^ _
+ nil nil nil nil nil
+;;; `
+ ("`"
+ (?e "\e$(2#_\e(B") (?u "\e$(2#`\e(B") (?U "\e$(2#`\e(B") (?i "\e$(2#a\e(B") (?a "\e$(2#b\e(B") (?A "\e$(2#b\e(B")
+ (?E "\e$(2#c\e(B") (?I "\e$(2#d\e(B") (?o "\e$(2#e\e(B") (?O "\e$(2#e\e(B")
+ (?s "\e$(2#V\e(B"
+ (?e "\e$(2#Q\e(B") (?u "\e$(2#R\e(B") (?i "\e$(2#S\e(B") (?a "\e$(2#T\e(B") (?E "\e$(2#U\e(B") (?o "\e$(2#W\e(B") (?| "\e$(2#V\e(B")
+ (?W "\e$(2"J\e(B" (?a "\e$(2"J\e(B")
+ (?e "\e$(2#V#L\e(B") (?u "\e$(2#V#M\e(B") (?i "\e$(2#V#N\e(B") (?E "\e$(2#V#P\e(B") (?' "\e$(2#V#M\e(B")))
+ (?S "\e$(2#]\e(B"
+ (?e "\e$(2#X\e(B") (?u "\e$(2#Y\e(B") (?i "\e$(2#Z\e(B") (?a "\e$(2#[\e(B") (?E "\e$(2#\\e(B") (?o "\e$(2#^\e(B") (?| "\e$(2#]\e(B")
+ (?W "\e$(2"R\e(B" (?a "\e$(2"R\e(B")
+ (?e "\e$(2#]#L\e(B") (?u "\e$(2#]#M\e(B") (?i "\e$(2#]#N\e(B") (?E "\e$(2#]#P\e(B") (?' "\e$(2#]#M\e(B")))
+ (?h "\e$(2#k\e(B"
+ (?e "\e$(2#f\e(B") (?u "\e$(2#g\e(B") (?i "\e$(2#h\e(B") (?a "\e$(2#i\e(B") (?E "\e$(2#j\e(B") (?o "\e$(2#l\e(B") (?| "\e$(2#k\e(B")
+ (?W "\e$(2"c\e(B" (?e "\e$(2"b\e(B") (?u "\e$(2"c\e(B") (?i "\e$(2"d\e(B") (?a "\e$(2"e\e(B") (?E "\e$(2"f\e(B")))
+ (?k "\e$(2#r\e(B"
+ (?e "\e$(2#m\e(B") (?u "\e$(2#n\e(B") (?i "\e$(2#o\e(B") (?a "\e$(2#p\e(B") (?E "\e$(2#q\e(B") (?o "\e$(2#s\e(B") (?| "\e$(2#r\e(B")))
+;;; a
+ ("\e$(2"S\e(B" (?2 "\e$(2#b\e(B"))
+
+;;; b
+ ("\e$(2!F\e(B" (?e "\e$(2!A\e(B") (?u "\e$(2!B\e(B") (?i "\e$(2!C\e(B") (?a "\e$(2!D\e(B") (?E "\e$(2!E\e(B") (?o "\e$(2!G\e(B") (?| "\e$(2!F\e(B")
+ (?W "\e$(2!H\e(B" (?a "\e$(2!H\e(B")
+ (?e "\e$(2!F#L\e(B") (?u "\e$(2!F#M\e(B") (?i "\e$(2!F#N\e(B") (?E "\e$(2!F#P\e(B") (?' "\e$(2!F#M\e(B")))
+;;; c
+ ("\e$(2!^\e(B" (?e "\e$(2!Y\e(B") (?u "\e$(2!Z\e(B") (?i "\e$(2![\e(B") (?a "\e$(2!\\e(B") (?E "\e$(2!]\e(B") (?o "\e$(2!_\e(B") (?| "\e$(2!^\e(B")
+ (?W "\e$(2!`\e(B" (?a "\e$(2!`\e(B")
+ (?e "\e$(2!^#L\e(B") (?u "\e$(2!^#M\e(B") (?i "\e$(2!^#N\e(B") (?E "\e$(2!^#P\e(B") (?' "\e$(2!^#M\e(B")))
+;;; d
+ ("\e$(2"(\e(B" (?e "\e$(2"#\e(B") (?u "\e$(2"$\e(B") (?i "\e$(2"%\e(B") (?a "\e$(2"&\e(B") (?E "\e$(2"'\e(B") (?o "\e$(2")\e(B") (?| "\e$(2"(\e(B")
+ (?W "\e$(2"*\e(B" (?a "\e$(2"*\e(B")
+ (?e "\e$(2"(#L\e(B") (?u "\e$(2"(#M\e(B") (?i "\e$(2"(#N\e(B") (?E "\e$(2"(#P\e(B") (?' "\e$(2"(#M\e(B")))
+;;; e
+ ("\e$(2"S\e(B" (?2 "\e$(2#_\e(B") (?3 "\e$(2"Z\e(B"))
+;;; f
+ ("\e$(2"@\e(B" (?e "\e$(2";\e(B") (?u "\e$(2"<\e(B") (?i "\e$(2"=\e(B") (?a "\e$(2">\e(B") (?E "\e$(2"?\e(B") (?o "\e$(2"A\e(B") (?| "\e$(2"@\e(B")
+ (?W "\e$(2"B\e(B" (?a "\e$(2"B\e(B")
+ (?e "\e$(2"@#L\e(B") (?u "\e$(2"@#M\e(B") (?i "\e$(2"@#N\e(B") (?E "\e$(2"@#P\e(B") (?' "\e$(2"@#M\e(B")))
+;;; g
+ ("\e$(2#>\e(B" (?e "\e$(2#9\e(B") (?u "\e$(2#:\e(B") (?i "\e$(2#;\e(B") (?a "\e$(2#<\e(B") (?E "\e$(2#=\e(B") (?o "\e$(2#?\e(B") (?| "\e$(2#>\e(B")
+ (?W "\e$(2#A\e(B" (?e "\e$(2#@\e(B") (?u "\e$(2#A\e(B") (?i "\e$(2#B\e(B") (?a "\e$(2#C\e(B") (?E "\e$(2#D\e(B")))
+;;; h
+ ("\e$(2"`\e(B" (?e "\e$(2"[\e(B") (?u "\e$(2"\\e(B") (?i "\e$(2"]\e(B") (?a "\e$(2"^\e(B") (?E "\e$(2"_\e(B") (?o "\e$(2"a\e(B") (?| "\e$(2"`\e(B")
+ (?W "\e$(2"c\e(B" (?e "\e$(2"b\e(B") (?u "\e$(2"c\e(B") (?i "\e$(2"d\e(B") (?a "\e$(2"e\e(B") (?E "\e$(2"f\e(B"))
+ (?2 "\e$(2#k\e(B" (?e "\e$(2#f\e(B") (?u "\e$(2#g\e(B") (?i "\e$(2#h\e(B") (?a "\e$(2#i\e(B") (?E "\e$(2#j\e(B") (?o "\e$(2#l\e(B")
+ (?| "\e$(2#k\e(B")
+ (?W "\e$(2"c\e(B" (?e "\e$(2"b\e(B") (?u "\e$(2"c\e(B") (?i "\e$(2"d\e(B") (?a "\e$(2"e\e(B") (?E "\e$(2"f\e(B"))))
+;;; i
+ ("\e$(2"U\e(B" (?2 "\e$(2#a\e(B"))
+;;; j
+ ("\e$(2$7\e(B" (?e "\e$(2$2\e(B") (?u "\e$(2$3\e(B") (?i "\e$(2$4\e(B") (?a "\e$(2$5\e(B") (?E "\e$(2$6\e(B") (?o "\e$(2$8\e(B") (?| "\e$(2$7\e(B"))
+;;; k
+ ("\e$(2"l\e(B" (?e "\e$(2"g\e(B") (?u "\e$(2"h\e(B") (?i "\e$(2"i\e(B") (?a "\e$(2"j\e(B") (?E "\e$(2"k\e(B") (?o "\e$(2"m\e(B") (?| "\e$(2"l\e(B")
+ (?W "\e$(2"o\e(B" (?e "\e$(2"n\e(B") (?u "\e$(2"o\e(B") (?i "\e$(2"p\e(B") (?a "\e$(2"q\e(B") (?E "\e$(2"r\e(B"))
+ (?2 "\e$(2#r\e(B" (?e "\e$(2#m\e(B") (?u "\e$(2#n\e(B") (?i "\e$(2#o\e(B") (?a "\e$(2#p\e(B") (?E "\e$(2#q\e(B") (?o "\e$(2#s\e(B")
+ (?| "\e$(2#r\e(B")))
+;;; l
+ ("\e$(2!&\e(B" (?e "\e$(2!!\e(B") (?u "\e$(2!"\e(B") (?i "\e$(2!#\e(B") (?a "\e$(2!$\e(B") (?E "\e$(2!%\e(B") (?o "\e$(2!'\e(B") (?| "\e$(2!&\e(B")
+ (?W "\e$(2!(\e(B" (?a "\e$(2!(\e(B")
+ (?e "\e$(2!&#L\e(B") (?u "\e$(2!&#M\e(B") (?i "\e$(2!&#N\e(B") (?E "\e$(2!&#P\e(B") (?' "\e$(2!&#M\e(B")))
+;;; m
+ ("\e$(2!.\e(B" (?e "\e$(2!)\e(B") (?u "\e$(2!*\e(B") (?i "\e$(2!+\e(B") (?a "\e$(2!,\e(B") (?E "\e$(2!-\e(B") (?o "\e$(2!/\e(B") (?| "\e$(2!.\e(B")
+ (?W "\e$(2!0\e(B" (?a "\e$(2!0\e(B")
+ (?e "\e$(2!.#L\e(B") (?u "\e$(2!.#M\e(B") (?i "\e$(2!.#N\e(B") (?E "\e$(2!.#P\e(B") (?' "\e$(2!.#M\e(B")))
+;;; n
+ ("\e$(2!f\e(B" (?e "\e$(2!a\e(B") (?u "\e$(2!b\e(B") (?i "\e$(2!c\e(B") (?a "\e$(2!d\e(B") (?E "\e$(2!e\e(B") (?o "\e$(2!g\e(B") (?| "\e$(2!f\e(B")
+ (?W "\e$(2!h\e(B" (?a "\e$(2!h\e(B")
+ (?e "\e$(2!f#L\e(B") (?u "\e$(2!f#M\e(B") (?i "\e$(2!f#N\e(B") (?E "\e$(2!f#P\e(B") (?' "\e$(2!f#M\e(B")))
+;;; o
+ ("\e$(2"Y\e(B" (?2 "\e$(2#e\e(B"))
+;;; p
+ ("\e$(2$L\e(B" (?e "\e$(2$G\e(B") (?u "\e$(2$H\e(B") (?i "\e$(2$I\e(B") (?a "\e$(2$J\e(B") (?E "\e$(2$K\e(B") (?o "\e$(2$M\e(B") (?| "\e$(2$L\e(B"))
+;;; q
+ ("\e$(2#&\e(B" (?e "\e$(2#!\e(B") (?u "\e$(2#"\e(B") (?i "\e$(2##\e(B") (?a "\e$(2#$\e(B") (?E "\e$(2#%\e(B") (?o "\e$(2#'\e(B") (?| "\e$(2#&\e(B")
+ (?W "\e$(2#)\e(B" (?e "\e$(2#(\e(B") (?u "\e$(2#)\e(B") (?i "\e$(2#*\e(B") (?a "\e$(2#+\e(B") (?E "\e$(2#,\e(B")))
+;;; r
+ ("\e$(2!6\e(B" (?e "\e$(2!1\e(B") (?u "\e$(2!2\e(B") (?i "\e$(2!3\e(B") (?a "\e$(2!4\e(B") (?E "\e$(2!5\e(B") (?o "\e$(2!7\e(B") (?| "\e$(2!6\e(B")
+ (?W "\e$(2!8\e(B" (?a "\e$(2!8\e(B")
+ (?e "\e$(2!6#L\e(B") (?u "\e$(2!6#M\e(B") (?i "\e$(2!6#N\e(B") (?E "\e$(2!6#P\e(B") (?' "\e$(2!6#M\e(B")))
+;;; s
+ ("\e$(2"H\e(B" (?e "\e$(2"C\e(B") (?u "\e$(2"D\e(B") (?i "\e$(2"E\e(B") (?a "\e$(2"F\e(B") (?E "\e$(2"G\e(B") (?o "\e$(2"I\e(B") (?| "\e$(2"H\e(B")
+ (?W "\e$(2"J\e(B" (?a "\e$(2"J\e(B")
+ (?e "\e$(2"H#L\e(B") (?u "\e$(2"H#M\e(B") (?i "\e$(2"H#N\e(B") (?E "\e$(2"H#P\e(B") (?' "\e$(2"H#M\e(B"))
+ (?2 "\e$(2#V\e(B" (?e "\e$(2#Q\e(B") (?u "\e$(2#R\e(B") (?i "\e$(2#S\e(B") (?a "\e$(2#T\e(B") (?E "\e$(2#U\e(B") (?o "\e$(2#W\e(B")
+ (?| "\e$(2#V\e(B")
+ (?W "\e$(2"J\e(B" (?a "\e$(2"J\e(B")
+ (?e "\e$(2#V#L\e(B") (?u "\e$(2#V#M\e(B") (?i "\e$(2#V#N\e(B") (?E "\e$(2#V#P\e(B")
+ (?' "\e$(2#V#M\e(B"))))
+;;; t
+ ("\e$(2!V\e(B" (?e "\e$(2!Q\e(B") (?u "\e$(2!R\e(B") (?i "\e$(2!S\e(B") (?a "\e$(2!T\e(B") (?E "\e$(2!U\e(B") (?o "\e$(2!W\e(B") (?| "\e$(2!V\e(B")
+ (?W "\e$(2!X\e(B" (?a "\e$(2!X\e(B")
+ (?e "\e$(2!V#L\e(B") (?u "\e$(2!V#M\e(B") (?i "\e$(2!V#N\e(B") (?E "\e$(2!V#P\e(B") (?' "\e$(2!V#M\e(B")))
+;;; u
+ ("\e$(2"T\e(B" (?2 "\e$(2#`\e(B"))
+;;; v
+ ("\e$(2!N\e(B" (?e "\e$(2!I\e(B") (?u "\e$(2!J\e(B") (?i "\e$(2!K\e(B") (?a "\e$(2!L\e(B") (?E "\e$(2!M\e(B") (?o "\e$(2!O\e(B") (?| "\e$(2!N\e(B")
+ (?W "\e$(2!P\e(B" (?a "\e$(2!P\e(B")
+ (?e "\e$(2!N#L\e(B") (?u "\e$(2!N#M\e(B") (?i "\e$(2!N#N\e(B") (?E "\e$(2!N#P\e(B") (?' "\e$(2!N#M\e(B")))
+;;; w
+ ("\e$(2#J\e(B" (?e "\e$(2#E\e(B") (?u "\e$(2#F\e(B") (?i "\e$(2#G\e(B") (?a "\e$(2#H\e(B") (?E "\e$(2#I\e(B") (?o "\e$(2#K\e(B") (?| "\e$(2#J\e(B")
+ (?W "\e$(2#M\e(B" (?e "\e$(2#L\e(B") (?u "\e$(2#M\e(B") (?i "\e$(2#N\e(B") (?a "\e$(2#O\e(B") (?E "\e$(2#P\e(B")))
+;;; x
+ ("\e$(2!>\e(B" (?e "\e$(2!9\e(B") (?u "\e$(2!:\e(B") (?i "\e$(2!;\e(B") (?a "\e$(2!<\e(B") (?E "\e$(2!=\e(B") (?o "\e$(2!?\e(B") (?| "\e$(2!>\e(B")
+ (?W "\e$(2!@\e(B" (?a "\e$(2!@\e(B")
+ (?e "\e$(2!>#L\e(B") (?u "\e$(2!>#M\e(B") (?i "\e$(2!>#N\e(B") (?E "\e$(2!>#P\e(B") (?' "\e$(2!>#M\e(B")))
+;;; y
+ ("\e$(2$)\e(B" (?e "\e$(2$$\e(B") (?u "\e$(2$%\e(B") (?i "\e$(2$&\e(B") (?a "\e$(2$'\e(B") (?E "\e$(2$(\e(B") (?o "\e$(2$*\e(B") (?| "\e$(2$)\e(B"))
+;;; z
+ ("\e$(2!v\e(B" (?e "\e$(2!q\e(B") (?u "\e$(2!r\e(B") (?i "\e$(2!s\e(B") (?a "\e$(2!t\e(B") (?E "\e$(2!u\e(B") (?o "\e$(2!w\e(B") (?| "\e$(2!v\e(B")
+ (?W "\e$(2!x\e(B" (?a "\e$(2!x\e(B")
+ (?e "\e$(2!v#L\e(B") (?u "\e$(2!v#M\e(B") (?i "\e$(2!v#N\e(B") (?E "\e$(2!v#P\e(B") (?' "\e$(2!v#M\e(B")))
+ ])
+
+;;;###autoload
+(defun sera-to-fidel-region (beg end &optional ascii-mode force)
+ "Translates the characters in region from SERA to FIDEL.
+
+If the 1st optional parameter ASCII-MODE is non-NIL, assumes that the
+region begins in ASCII script.
+
+If the 2nd optional parametr FORCE is non-NIL, translates even if the
+buffer is read-only."
+
+ (interactive "r\nP")
+ (save-excursion
+ (save-restriction
+ (narrow-to-region beg end)
+ (sera-to-fidel-buffer ascii-mode force))))
+
+;;;###autoload
+(defun sera-to-fidel-buffer (&optional ascii-mode force)
+ "Translates the current buffer from SERA to FIDEL.
+
+If the 1st optional parameter ASCII-MODE is non-NIL, assumes that the
+current buffer begins in ASCII script.
+
+If the 2nd optional panametr FORCE is non-NIL, translates even if the
+buffer is read-only."
+
+ (interactive "P")
+ (if (and buffer-read-only
+ (not force)
+ (not (y-or-n-p "Buffer is read-only. Force to convert? ")))
+ (error ""))
+ (let (start pre fol hard table table2 (buffer-read-only nil))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq start (point))
+ (forward-char 1)
+ (setq pre (preceding-char)
+ fol (following-char))
+
+ (if ascii-mode
+ (cond
+
+ ;; ascii mode, pre != \
+ ((/= pre ?\\ ))
+
+ ;; ascii mode, pre = \, fol = !
+ ((= fol ?!)
+ (backward-delete-char 1)
+ (delete-char 1)
+ (setq ascii-mode nil
+ hard (not hard)))
+
+ ;; hard ascii mode, pre = \, fol != !
+ (hard)
+
+ ;; soft ascii mode, pre = \, fol = {\ _ * < > 0..9 ~}
+ ((or (backward-delete-char 1) ; always nil
+ (eobp)
+ (sera-to-fidel-backslash)))
+
+ ;; soft ascii mode, pre = \, fol = SPC
+ ((= fol 32)
+ (delete-char 1)
+ (setq ascii-mode nil))
+
+ ;; soft ascii mode, pre = \, fol = .
+ ((= fol ?.)
+ (delete-char 1)
+ (insert ?\e$(2$P\e(B))
+
+ ;; soft ascii mode, pre = \, fol = ,
+ ((= fol ?,)
+ (delete-char 1)
+ (insert ?\e$(2$Q\e(B))
+
+ ;; soft ascii mode, pre = \, fol = ;
+ ((= fol ?\;)
+ (delete-char 1)
+ (insert ?\e$(2$R\e(B))
+
+ ;; soft ascii mode, pre = \, fol = :
+ ((= fol ?:)
+ (delete-char 1)
+ (insert ?\e$(2$S\e(B))
+
+ ;; soft ascii mode, pre = \, fol = others
+ (t
+ (setq ascii-mode nil)))
+
+ (cond
+
+ ;; very special: skip "<" to ">" (or "&" to ";") if in w3-mode
+ ((and (boundp 'sera-being-called-by-w3)
+ sera-being-called-by-w3
+ (or (= pre ?<) (= pre ?&)))
+ (search-forward (if (= pre ?<) ">" ";")
+ nil 0))
+
+ ;; ethio mode, pre != sera
+ ((or (< pre ?') (> pre ?z)))
+
+ ;; ethio mode, pre != \
+ ((/= pre ?\\ )
+ (setq table (aref sera-to-fidel-table pre))
+ (while (setq table2 (cdr (assoc (following-char) table)))
+ (setq table table2)
+ (forward-char 1))
+ (if (car table)
+ (progn
+ (delete-region start (point))
+ (insert (car table)))))
+
+ ;; ethio mode, pre = \, fol = !
+ ((= fol ?!)
+ (backward-delete-char 1)
+ (delete-char 1)
+ (setq ascii-mode t
+ hard (not hard)))
+
+ ;; hard ethio mode, pre = \, fol != !
+ (hard)
+
+ ;; soft ethio mode, pre = \, fol = {\ _ * < > 0..9 ~}
+ ((or (backward-delete-char 1) ; always nil
+ (eobp)
+ (sera-to-fidel-backslash)))
+
+ ;; soft ethio mode, pre = \, fol = SPC
+ ((= fol 32)
+ (delete-char 1)
+ (setq ascii-mode t))
+
+ ;; soft ethio mode, pre = \, fol = {. , ; : | ' `}
+ ((memq fol '(?. ?, ?\; ?: ?| ?' ?`))
+ (forward-char 1))
+
+ ;; soft ethio mode, pre = \, fol = others
+ (t
+ (setq ascii-mode t))))))
+ (goto-char (point-min)))
+
+(defun sera-to-fidel-backslash ()
+ "Handle SERA backslash escapes common to ethio- and ascii-mode.
+Returns t if something has been processed."
+ (let ((ch (following-char))
+ (converted t))
+ (if (and (>= ch ?1) (<= ch ?9))
+ (ethio-convert-digit)
+ (delete-char 1)
+ (cond
+ ((= ch ?\\ )
+ (insert ?\\ ))
+ ((= ch ?_)
+ (insert ?\e$(2$O\e(B))
+ ((= ch ?*)
+ (insert ?\e$(2$T\e(B))
+ ((= ch ?<)
+ (insert ?\e$(2$U\e(B))
+ ((= ch ?>)
+ (insert ?\e$(2$V\e(B))
+ ((= ch ?~)
+ (setq ch (following-char))
+ (delete-char 1)
+ (cond
+ ((= ch ?e)
+ (insert "\e$(2$k\e(B"))
+ ((= ch ?E)
+ (insert "\e$(2$l\e(B"))
+ ((= ch ?a)
+ (insert "\e$(2$m\e(B"))
+ ((= ch ?A)
+ (insert "\e$(2$n\e(B"))))
+ (t
+ (insert ch)
+ (backward-char 1)
+ (setq converted nil))))
+ converted))
+
+(defun ethio-convert-digit ()
+ "Convert Arabic digits to Ethiopic digits."
+ (let (ch z)
+ (while (and (>= (setq ch (following-char)) ?1)
+ (<= ch ?9))
+ (delete-char 1)
+
+ ;; count up following zeros
+ (setq z 0)
+ (while (= (following-char) ?0)
+ (delete-char 1)
+ (setq z (1+ z)))
+
+ (cond
+
+ ;; first digit is 10, 20, ..., or 90
+ ((= (mod z 2) 1)
+ ;; (- ch 40) means ?1 -> 9, ?2 -> 10, etc.
+ (insert (aref [?\e$(2$`\e(B ?\e$(2$a\e(B ?\e$(2$b\e(B ?\e$(2$c\e(B ?\e$(2$d\e(B ?\e$(2$e\e(B ?\e$(2$f\e(B ?\e$(2$g\e(B ?\e$(2$h\e(B] (- ch ?1)))
+ (setq z (1- z)))
+
+ ;; first digit is 2, 3, ..., or 9
+ ((/= ch ?1)
+ (insert (aref [?\e$(2$X\e(B ?\e$(2$Y\e(B ?\e$(2$Z\e(B ?\e$(2$[\e(B ?\e$(2$\\e(B ?\e$(2$]\e(B ?\e$(2$^\e(B ?\e$(2$_\e(B] (- ch ?2))))
+
+ ;; single 1
+ ((= z 0)
+ (insert "\e$(2$W\e(B")))
+
+ ;; 100
+ (if (= (mod z 4) 2)
+ (insert"\e$(2$i\e(B"))
+
+ ;; 10000
+ (insert-char ?\e$(2$j\e(B (/ z 4)))))
+
+;;;###autoload
+(defun sera-to-fidel-mail (&optional arg)
+ "Does SERA to FIDEL conversion for reading/writing mail and news.
+
+If the buffer contains the markers \"<sera>\" and \"</sera>\",
+converts the segment between the two markers in Ethio start mode and
+the subject field in ASCII start mode.
+
+If invoked interactively and there is no marker, converts both the
+whole body and the subject field in Ethio start mode.
+
+For backward compatibility, \"<ethiopic>\" and \"<>\" can be used instead of
+\"<sera>\" and \"</sera>\"."
+
+ (interactive "p")
+ (let* ((buffer-read-only nil) border)
+
+ (save-excursion
+ (goto-char (point-min))
+ (setq border
+ (search-forward
+ (if (eq major-mode 'rmail-mode)
+ "\n\n"
+ (concat "\n" mail-header-separator "\n"))))
+
+ (cond
+
+ ;; with markers
+ ((re-search-forward "^<sera>\n" nil t)
+ (goto-char (match-beginning 0))
+ (while (re-search-forward "^<sera>\n" nil t)
+ (replace-match "" nil t)
+ (sera-to-fidel-region
+ (point)
+ (progn
+ (if (re-search-forward "^</sera>\n" nil 0)
+ (replace-match "" nil t))
+ (point))))
+
+ (goto-char (point-min))
+ (if (re-search-forward "^Subject: " border t)
+ (sera-to-fidel-region
+ (point)
+ (progn (end-of-line) (point))
+ 'ascii-start)))
+
+ ;; backward compatibility
+ ((re-search-forward "^<ethiopic>\n" nil t)
+ (goto-char (match-beginning 0))
+ (while (re-search-forward "^<ethiopic>\n" nil t)
+ (replace-match "" nil t)
+ (sera-to-fidel-region
+ (setq border (point))
+ (progn
+ (if (re-search-forward "^<>\n" nil 0)
+ (replace-match "" nil t))
+ (point))))
+
+ (goto-char (point-min))
+ (if (re-search-forward "^Subject: " border t)
+ (sera-to-fidel-region
+ (point)
+ (progn (end-of-line) (point))
+ 'ascii-start)))
+
+ ;; interactive & no markers
+ (arg
+ (sera-to-fidel-region border (point-max))
+ (goto-char (point-min))
+ (if (re-search-forward "^Subject: " border t)
+ (sera-to-fidel-region
+ (point)
+ (progn (end-of-line) (point))))))
+
+ ;; adjust the rmail marker
+ (if (eq major-mode 'rmail-mode)
+ (set-marker
+ (aref rmail-message-vector (1+ rmail-current-message))
+ (point-max))))))
+
+;;;###autoload
+(defun sera-to-fidel-marker ()
+ "If the buffer contains the markers \"<sera>\" and \"</sera>\",
+converts the segment between the two markers from SERA to Fidel
+in Ethio start mode. The markers will not be removed."
+
+ (interactive)
+ (if (and buffer-read-only
+ (not (y-or-n-p "Buffer is read-only. Force to convert? ")))
+ (error ""))
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "<sera>" nil t)
+ (sera-to-fidel-region
+ (point)
+ (if (re-search-forward "</sera>" nil t)
+ (match-beginning 0)
+ (point-max))
+ nil
+ 'force))))
+
+;;
+;; FIDEL to SERA
+;;
+
+(defconst fidel-to-sera-map
+ ["le" "lu" "li" "la" "lE" "l" "lo" "lWa"
+ "me" "mu" "mi" "ma" "mE" "m" "mo" "mWa"
+ "re" "ru" "ri" "ra" "rE" "r" "ro" "rWa"
+ "xe" "xu" "xi" "xa" "xE" "x" "xo" "xWa"
+ "be" "bu" "bi" "ba" "bE" "b" "bo" "bWa"
+ "ve" "vu" "vi" "va" "vE" "v" "vo" "vWa"
+ "te" "tu" "ti" "ta" "tE" "t" "to" "tWa"
+ "ce" "cu" "ci" "ca" "cE" "c" "co" "cWa"
+ "ne" "nu" "ni" "na" "nE" "n" "no" "nWa"
+ "Ne" "Nu" "Ni" "Na" "NE" "N" "No" "NWa"
+ "ze" "zu" "zi" "za" "zE" "z" "zo" "zWa"
+ "Ze" "Zu" "Zi" "Za" "ZE" "Z" "Zo" "ZWa"
+ "de" "du" "di" "da" "dE" "d" "do" "dWa"
+ "Te" "Tu" "Ti" "Ta" "TE" "T" "To" "TWa"
+ "Ce" "Cu" "Ci" "Ca" "CE" "C" "Co" "CWa"
+ "fe" "fu" "fi" "fa" "fE" "f" "fo" "fWa"
+ "se" "su" "si" "sa" "sE" "s" "so" "sWa"
+ "Se" "Su" "Si" "Sa" "SE" "S" "So" "SWa"
+ "a" "u" "i" "A" "E" "I" "o" "e3"
+ "he" "hu" "hi" "ha" "hE" "h" "ho" "hWe" "hWu" "hWi" "hWa" "hWE"
+ "ke" "ku" "ki" "ka" "kE" "k" "ko" "kWe" "kWu" "kWi" "kWa" "kWE"
+ "Ke" "Ku" "Ki" "Ka" "KE" "K" "Ko" "KWe" "KWu" "KWi" "KWa" "KWE"
+ "qe" "qu" "qi" "qa" "qE" "q" "qo" "qWe" "qWu" "qWi" "qWa" "qWE"
+ "Qe" "Qu" "Qi" "Qa" "QE" "Q" "Qo" "QWe" "QWu" "QWi" "QWa" "QWE"
+ "ge" "gu" "gi" "ga" "gE" "g" "go" "gWe" "gWu" "gWi" "gWa" "gWE"
+ "we" "wu" "wi" "wa" "wE" "w" "wo" "wWe" "wWu" "wWi" "wWa" "wWE"
+ "`se" "`su" "`si" "`sa" "`sE" "`s" "`so"
+ "`Se" "`Su" "`Si" "`Sa" "`SE" "`S" "`So"
+ "`e" "`u" "`i" "`a" "`E" "`I" "`o"
+ "`he" "`hu" "`hi" "`ha" "`hE" "`h" "`ho"
+ "`ke" "`ku" "`ki" "`ka" "`kE" "`k" "`ko"
+ "Xe" "Xu" "Xi" "Xa" "XE" "X" "Xo"
+ "He" "Hu" "Hi" "Ha" "HE" "H" "Ho"
+ "ye" "yu" "yi" "ya" "yE" "y" "yo"
+ "De" "Du" "Di" "Da" "DE" "D" "Do"
+ "je" "ju" "ji" "ja" "jE" "j" "jo"
+ "Ge" "Gu" "Gi" "Ga" "GE" "G" "Go"
+ "Pe" "Pu" "Pi" "Pa" "PE" "P" "Po"
+ "pe" "pu" "pi" "pa" "pE" "p" "po"
+ " " "\\_" "." "," ";" ":" "\\*" "\\<" "\\>"
+ "1" "2" "3" "4" "5" "6" "7" "8" "9"
+ "10" "20" "30" "40" "50" "60" "70" "80" "90"
+ "100" "10000"
+ "\\~e" "\\~E" "\\~a" "\\~A"])
+
+(defvar ethio-use-tigrigna-style nil
+ "*If non-NIL, use \"e\" instead of \"a\" for the first lone vowel
+translation in sera-to-fidel and fidel-to-sera conversions.")
+
+(defvar ethio-quote-vowel-always nil
+ "*If non-NIL, lone vowels are always transcribed by \"an apostrophe
++ the vowel\" except at word initial. Otherwise, they are quoted by
+an apostrophe only if the preceding Ethiopic character is a lone
+consonant.")
+
+(defvar ethio-W-sixth-always nil
+ "*If non-NIL, the Wu-form of a 12-form consonant is transcribed by
+\"W'\" instead of \"Wu\".")
+
+(defvar ethio-numeric-reduction 0
+ "*Degree of reduction in transcribing Ethiopic digits by Arabic
+digits. For example, \e$(2$`$_$i$g$]\e(B ({10}{9}{100}{80}{7}) will be
+transcribed by:
+ \10\9\100\80\7 if ETHIO-NUMERIC-REDUCTION is 0,
+ \109100807 is 1,
+ \10900807 is 2.")
+
+;;;###autoload
+(defun fidel-to-sera-region (begin end &optional ascii-mode force)
+ "Replaces all the FIDEL characters in the region to sera format.
+
+If the 1st optional parameter ASCII-MODE is non-NIL, converts the
+region so that it begins in ASCII script.
+
+If the 2nd optional parameter FORCE is non-NIL, converts even if the
+buffer is read-only."
+
+ (interactive "r\nP")
+ (save-excursion
+ (save-restriction
+ (narrow-to-region begin end)
+ (fidel-to-sera-buffer ascii-mode force))))
+
+;;;###autoload
+(defun fidel-to-sera-buffer (&optional ascii-mode force)
+ "Replace all the FIDEL characters in the current buffer to sera format.
+
+If the 1st optional parameter ASCII-MODE is non-NIL,
+convert the current buffer so that it begins in ASCII script.
+
+If the 2nd optional parameter FORCE is non-NIL, converts even if the
+buffer is read-only.
+
+See also the description of the variables ethio-use-tigrigna-style,
+ethio-quote-vowel-on-demand and ethio-numeric-reduction."
+
+ (interactive "P")
+ (if (and buffer-read-only
+ (not force)
+ (not (y-or-n-p "Buffer is read-only. Force to convert? ")))
+ (error ""))
+
+ ;; user's preference in transcription
+ (aset fidel-to-sera-map 144 (if ethio-use-tigrigna-style "e" "a"))
+ (let ((i 160)
+ (x (if ethio-W-sixth-always
+ '("hW'" "kW'" "KW'" "qW'" "QW'" "gW'" "wW'")
+ '("hWu" "kWu" "KWu" "qWu" "QWu" "gWu" "wWu"))))
+ (while x
+ (aset fidel-to-sera-map i (car x))
+ (setq i (+ i 12)
+ x (cdr x))))
+
+ ;; main conversion routine
+ (let ((lonec nil) ; if lonec = t, previous char was a lone consonant.
+ (fidel nil) ; if fidel = t, previous char was a fidel.
+ (digit nil) ; if digit = t, previous char was an Ethiopic digit.
+ (buffer-read-only nil)
+ ch)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq ch (following-char))
+
+ ;; ethiopic charactes
+ (if (eq (char-charset ch) 'ethiopic)
+ (progn
+ (setq ch (char-to-ethiocode ch))
+ (delete-char 1)
+
+ (cond
+
+ ;; fidels
+ ((<= ch 326)
+ (if ascii-mode
+ (insert "\\ "))
+ (if (and (memq ch '(144 145 146 147 148 150 151)) ; (auiAEoe3)
+ (or lonec
+ (and ethio-quote-vowel-always
+ fidel)))
+ (insert "'"))
+ (insert (aref fidel-to-sera-map ch))
+ (setq ascii-mode nil
+ lonec (ethio-lone-consonant-p ch)
+ fidel t
+ digit nil))
+
+ ;; punctuations and symbols
+ ((or (< ch 336) (> ch 355))
+ (if (and ascii-mode
+ (memq ch '(329 330 331 332))) ; (.,;:)
+ (insert "\\"))
+ (insert (aref fidel-to-sera-map ch))
+ (setq lonec nil
+ fidel nil
+ digit nil))
+
+ ;; now CH must be an ethiopic digit
+
+ ;; reduction = 0 or leading digit
+ ((or (= ethio-numeric-reduction 0)
+ (not digit))
+ (insert "\\" (aref fidel-to-sera-map ch))
+ (setq lonec nil
+ fidel nil
+ digit t))
+
+ ;; reduction = 2 and following 10s, 100s, 10000s
+ ((and (= ethio-numeric-reduction 2)
+ (memq ch '(345 354 355)))
+ (insert (substring (aref fidel-to-sera-map ch) 1))
+ (setq lonec nil
+ fidel nil
+ digit t))
+
+ ;; ordinary following digits
+ (t
+ (insert (aref fidel-to-sera-map ch))
+ (setq lonec nil
+ fidel nil
+ digit t))))
+
+ ;; non-ethiopic characters
+ (cond
+
+ ;; backslash is always quoted
+ ((= ch ?\\ )
+ (insert "\\"))
+
+ ;; nothing to do if in ascii-mode
+ (ascii-mode)
+
+ ;; ethio-mode -> ascii-mode
+ ((or (and (>= ch ?a) (<= ch ?z))
+ (and (>= ch ?A) (<= ch ?Z))
+ (memq ch '(?| ?' ?`)))
+ (insert "\\ ")
+ (setq ascii-mode t))
+
+ ;; ascii punctuations in ethio-mode
+ ((memq ch '(?. ?, ?\; ?:))
+ (insert "\\")))
+
+ (forward-char 1)
+ (setq lonec nil
+ fidel nil
+ digit nil)))
+
+ ;; a few modifications for readability
+ (goto-char (point-min))
+ (while (re-search-forward "\\([]!\"#$%&()*+/<=>?@[^_-]+\\)\\\\ " nil t)
+ (replace-match "\\\\ \\1"))
+
+ (goto-char (point-min))
+ (while (re-search-forward "\n\\([ \t]*\\)\\\\ " nil t)
+ (replace-match "\\\\\n\\1")))
+
+ (goto-char (point-min)))
+
+(defun ethio-lone-consonant-p (code)
+ "If the ethiocode CODE is an Ethiopic lone consonant, return t."
+ (cond
+ ((< code 144)
+ (= (mod code 8) 5))
+ ((< code 153)
+ nil)
+ ((< code 236)
+ (= (mod code 12) 1))
+ ((< code 327)
+ (= (mod code 7) 3))))
+
+;;;###autoload
+(defun fidel-to-sera-mail ()
+ "Does FIDEL to SERA conversion for reading/writing mail and news.
+
+If the buffer contains at least one Ethiopic character,
+ 1) inserts the string \"<sera>\" right after the header-body separator,
+ 2) inserts \"</sera>\" at the end of the buffer,
+ 3) converts the body into SERA in Ethiopic start mode, and
+ 4) converts the subject field in ASCII start mode."
+
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward "\\cE" nil t)
+ (let ((buffer-read-only nil) border)
+
+ (goto-char (point-min))
+ (setq border
+ (search-forward
+ (if (eq major-mode 'rmail-mode)
+ "\n\n"
+ (concat "\n" mail-header-separator "\n"))))
+ (insert "<sera>\n")
+
+ (fidel-to-sera-region (point) (point-max))
+
+ (goto-char (point-max))
+ (if (/= (preceding-char) ?\n)
+ (insert "\n"))
+ (insert "</sera>\n")
+
+ (goto-char (point-min))
+ (if (re-search-forward "^Subject: " border t)
+ (fidel-to-sera-region
+ (point)
+ (progn (end-of-line) (point))
+ 'ascii-start))
+
+ ;; adjust the rmail marker
+ (if (eq major-mode 'rmail-mode)
+ (set-marker
+ (aref rmail-message-vector (1+ rmail-current-message))
+ (point-max))))
+
+ (message "No Ethiopic characters in this buffer."))))
+
+;;;###autoload
+(defun fidel-to-sera-marker ()
+ "If the buffer contains the markers \"<sera>\" and \"</sera>\",
+converts the segment between the two markers from Fidel to SERA
+in Ethio start mode. The markers will not be removed."
+
+ (interactive)
+ (if (and buffer-read-only
+ (not (y-or-n-p "Buffer is read-only. Force to convert? ")))
+ (error ""))
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "^<sera>\n" nil t)
+ (fidel-to-sera-region
+ (point)
+ (if (re-search-forward "^</sera>\n" nil t)
+ (match-beginning 0)
+ (point-max))
+ nil
+ 'force))))
+
+;;
+;; file I/O hooks
+;;
+
+(if (not (assoc "\\.sera$" auto-mode-alist))
+ (setq auto-mode-alist
+ (cons '("\\.sera$" . sera-to-fidel-find-file) auto-mode-alist)))
+(add-hook 'write-file-hooks 'fidel-to-sera-write-file)
+(add-hook 'after-save-hook 'sera-to-fidel-after-save)
+
+;;;###autoload
+(defun sera-to-fidel-find-file ()
+ "Intended to be called when a file whose name ends in \".sera\" is read in."
+ (sera-to-fidel-buffer nil 'force)
+ (set-buffer-modified-p nil)
+ nil)
+
+;;;###autoload
+(defun fidel-to-sera-write-file ()
+ "Intended to be used as write-file-hooks for the files
+whose name ends in \".sera\"."
+ (if (string-match "\\.sera$" (buffer-file-name))
+ (save-excursion
+ (fidel-to-sera-buffer nil 'force)
+ (set-buffer-modified-p nil)))
+ nil)
+
+;;;###autoload
+(defun sera-to-fidel-after-save ()
+ "Intended to be used as after-save-hook for the files
+whose name ends in \".sera\"."
+ (if (string-match "\\.sera$" (buffer-file-name))
+ (save-excursion
+ (sera-to-fidel-buffer nil 'force)
+ (set-buffer-modified-p nil)))
+ nil)
+
+;;
+;; vowel modification
+;;
+
+;;;###autoload
+(defun ethio-modify-vowel ()
+ "Modify the vowel of the FIDEL that is under the cursor."
+ (interactive)
+ (let ((ch (following-char)) newch base vowel)
+ (if (eq (char-charset ch) 'ethiopic)
+ (setq ch (char-to-ethiocode ch))
+ (error "Not a valid character."))
+ (if (or (and (>= ch 144) (<= ch 151)) ; lone vowels
+ (and (>= ch 250) (<= ch 256)) ; secondary lone vowels
+ (>= ch 327)) ; not FIDEL
+ (error "Not a valid character."))
+ (message "Modify vowel to: ")
+ (if (null (setq vowel (memq (read-char) '(?e ?u ?i ?a ?E ?' ?o))))
+ (error "Not a valid vowel.")
+ ;; ?e -> 0, ?u -> 1, ?i -> 2, ?a -> 3, ?E -> 4, ?' -> 5, ?o -> 6
+ (setq vowel (- 7 (length vowel))))
+
+ (cond
+
+ ;; 8-form consonant
+ ((<= ch 143)
+ (setq base (* (/ ch 8) 8))
+ (cond
+ ((< (mod ch 8) 7) ; e-form <= ch <= o-form
+ (setq newch (+ base vowel)))
+ ((= vowel 3) ; 3 = a
+ (setq newch (+ base 7))) ; (+ base 7) = Wa-form
+ ((= vowel 5) ; 5 = '
+ (setq newch
+ (cons (+ base 5) ; (+ base 5) = lone consonant
+ 232))) ; 232 = Wu
+ (t
+ (setq newch
+ (cons (+ base 5) ; (+ base 5) = lone consonant
+ (+ 231 vowel)))))) ; 231 = We
+
+ ;; 12-form consonant
+ ((<= ch 235)
+ (setq ch (- ch 152) ; 152 = 12-form consonant offset
+ base (* (/ ch 12) 12))
+ (cond
+ ((< (mod ch 12) 7) ; e-form <= ch <= o-form
+ (setq newch (+ base vowel 152)))
+ ((< vowel 5) ; We-form <= ch <= WE-form
+ (setq newch (+ base vowel 159))) ; 159 = 152 (offset) + 7 (We-form)
+ ((= vowel 5) ; 5 = ' (= u in this case)
+ (setq newch (+ base 160))) ; 160 = 152 (offset) + 8 (Wu-form)
+ (t
+ (error "Not a valid vowel."))))
+
+ ;; 7-form consonant
+ (t ; 236 = 7-form consonant offset
+ (setq newch (+ (* (/ (- ch 236) 7) 7) vowel 236))))
+
+ (delete-char 1)
+
+ (cond
+ ((consp newch)
+ (insert (ethiocode-to-char (car newch))
+ (ethiocode-to-char (cdr newch)))
+ (backward-char 2))
+ (t
+ (insert (ethiocode-to-char newch))
+ (backward-char 1)))))
+
+(defun ethiocode-to-char (code)
+ (make-char 'ethiopic (/ code 94) (mod code 94)))
+
+(defun char-to-ethiocode (ch)
+ (and (eq (char-charset ch) 'ethiopic)
+ (let ((char-components (split-char ch)))
+ (+ (* (- (nth char-components 1) 161) 94)
+ (- (nth char-components 2) 161)))))
+
+;;
+;; space replacement
+;;
+
+;;;###autoload
+(defun ethio-replace-space (ch begin end)
+ "In the specified region, replace spaces between two Ethiopic characters."
+ (interactive "*cReplace spaces to: 1 (sg col), 2 (dbl col), 3 (Ethiopic)\nr")
+ (if (not (memq ch '(?1 ?2 ?3)))
+ (error ""))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region begin end)
+ (goto-char (point-min))
+
+ (cond
+
+ ((= ch ?1)
+
+ ;; A double column space or an Ethiopic word separator is always
+ ;; converted to an ASCII space.
+ (while (re-search-forward "[\e$(2$N$O\e(B]" nil t)
+ (replace-match " " nil nil)))
+
+ ((= ch ?2)
+
+ ;; An Ethiopic word separator is always converted to
+ ;; a double column space.
+ (while (search-forward "\e$(2$O\e(B" nil t)
+ (replace-match "\e$(2$N\e(B"))
+
+ (goto-char (point-min))
+
+ ;; ASCII spaces are converted only if they are placed
+ ;; between two Ethiopic characters.
+ (while (re-search-forward "\\(\\cE\\)\\( \\)\\( *\\cE\\)" nil t)
+
+ ;; Converting the first ASCII space
+ (replace-match "\\1\e$(2$N\e(B\\3")
+
+ ;; A double column space is \cE, so going back to the just
+ ;; converted double column space makes it possible to find
+ ;; the following ASCII spaces.
+ (goto-char (match-beginning 2))))
+
+ ((= ch ?3)
+
+ ;; If more than one consecutive space (either ASCII or double
+ ;; width) is found between two Ethiopic characters, the first
+ ;; space will be converted to an Ethiopic word separator.
+ (let (pred succ)
+ (while (re-search-forward "[ \e$(2$N\e(B]\\([ \e$(2$N\e(B]*\\)" nil t)
+ (and (setq pred (char-before (match-beginning 0)))
+ (eq (char-charset pred) 'ethiopic)
+ (setq succ (char-after (match-end 0)))
+ (eq (char-charset succ) 'ethiopic)
+ (replace-match "\e$(2$O\e(B\\1" nil nil)))))))))
+
+;;
+;; special characters
+;;
+
+;;;###autoload
+(defun ethio-input-special-character (arg)
+ "Allow the user to input special characters."
+ (interactive "*cInput number: 1.\e$(2$k\e(B 2.\e$(2$l\e(B 3.\e$(2$m\e(B 4.\e$(2$n\e(B")
+ (cond
+ ((= arg ?1)
+ (insert ?\e$(2$k\e(B))
+ ((= arg ?2)
+ (insert ?\e$(2$l\e(B))
+ ((= arg ?3)
+ (insert ?\e$(2$m\e(B))
+ ((= arg ?4)
+ (insert ?\e$(2$n\e(B))
+ (t
+ (error ""))))
+
+;;
+(provide 'language/ethio-util)
+
+;;; Local Variables:
+;;; generated-autoload-file: "../loaddefs.el"
+;;; End:
+;;; ethio-util.el ends here
--- /dev/null
+;;; ethiopic.el --- Support for Ethiopic
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: multilingual, Ethiopic
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Code:
+
+(define-ccl-program ccl-encode-ethio-font
+ '(0
+ ;; In: R0:ethio (not checked)
+ ;; R1:position code 1
+ ;; R2:position code 2
+ ;; Out: R1:font code point 1
+ ;; R2:font code point 2
+ ((r1 -= 33)
+ (r2 -= 33)
+ (r1 *= 94)
+ (r2 += r1)
+ (if (r2 < 256) (r1 = 0) ((r2 -= 256) (r1 = 1)))))
+ "CCL program to encode an Ehitopic code to code point of Ehitopic font.")
+
+(setq font-ccl-encoder-alist
+ (cons (cons "ethio" ccl-encode-ethio-font) font-ccl-encoder-alist))
+
+(register-input-method
+ "Ethiopic" '("quail-ethio" quail-use-package "quail/ethio"))
+
+(defun setup-ethio-environment ()
+ (setq primary-language "Ethiopic")
+
+ (setq default-input-method '("Ethiopic" . "quail-ethio"))
+
+ ;;
+ ;; key bindings
+ ;;
+ (define-key global-map [f4] 'sera-to-fidel-buffer)
+ (define-key global-map [S-f4] 'sera-to-fidel-region)
+ (define-key global-map [C-f4] 'sera-to-fidel-marker)
+ (define-key global-map [f5] 'fidel-to-sera-buffer)
+ (define-key global-map [S-f5] 'fidel-to-sera-region)
+ (define-key global-map [C-f5] 'fidel-to-sera-marker)
+ (define-key global-map [f6] 'ethio-modify-vowel)
+ (define-key global-map [f7] 'ethio-replace-space)
+ (define-key global-map [S-f2] 'ethio-replace-space) ; as requested
+ (define-key global-map [f8] 'ethio-input-special-character)
+
+ (add-hook
+ 'rmail-mode-hook
+ '(lambda ()
+ (define-key rmail-mode-map [C-f4] 'sera-to-fidel-mail)
+ (define-key rmail-mode-map [C-f5] 'fidel-to-sera-mail)))
+
+ (add-hook
+ 'mail-mode-hook
+ '(lambda ()
+ (define-key mail-mode-map [C-f4] 'sera-to-fidel-mail)
+ (define-key mail-mode-map [C-f5] 'fidel-to-sera-mail)))
+ )
+
+(set-language-info-alist
+ "Ethiopic" '((setup-function . setup-ethio-environment)
+ (charset . (ethiopic))
+ (documentation . t)
+ (sample-text
+ . "Amharic (\e$(2"S!,!6!l\e(B) \e$(2#Q!$!.\e(B, Tigrigna (\e$(2!V#>!6!l\e(B) \e$(2"C!$!,!V\e(B")))
+
+;;; ethiopic.el ends here
--- /dev/null
+;;; european.el --- Support for European languages
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: multilingual, European
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; For Europeans, five character sets ISO8859-1,2,3,4,9 are supported.
+
+;;; Code:
+
+(make-coding-system
+ 'coding-system-iso-8859-1 2 ?X
+ "Coding-system used in X as Compound Text Encoding."
+ '((ascii t) (latin-iso8859-1 t) nil nil
+ nil ascii-eol ascii-cntl))
+
+;; CTEXT is an alias for ISO-8859-1
+(put 'coding-system-ctext 'coding-system 'coding-system-iso-8859-1)
+
+(make-coding-system
+ 'coding-system-iso-8859-2 2 ?2 "MIME ISO-8859-2"
+ '((ascii t) (latin-iso8859-2 t) nil nil
+ nil ascii-eol ascii-cntl nil nil nil nil))
+
+(make-coding-system
+ 'coding-system-iso-8859-3 2 ?3 "MIME ISO-8859-3"
+ '((ascii t) (latin-iso8859-3 t) nil nil
+ nil ascii-eol ascii-cntl nil nil nil nil))
+
+(make-coding-system
+ 'coding-system-iso-8859-4 2 ?4 "MIME ISO-8859-4"
+ '((ascii t) (latin-iso8859-4 t) nil nil
+ nil ascii-eol ascii-cntl nil nil nil nil))
+
+(make-coding-system
+ 'coding-system-iso-8859-9 2 ?9 "MIME ISO-8859-9"
+ '((ascii t) (latin-iso8859-9 t) nil nil
+ nil ascii-eol ascii-cntl nil nil nil nil))
+
+(register-input-method "European"
+ '("quail-latin-1" quail-use-package "quail/latin"))
+(register-input-method "European"
+ '("quail-latin-2" quail-use-package "quail/latin"))
+(register-input-method "European"
+ '("quail-latin-3" quail-use-package "quail/latin"))
+(register-input-method "European"
+ '("quail-latin-4" quail-use-package "quail/latin"))
+(register-input-method "European"
+ '("quail-latin-5" quail-use-package "quail/latin"))
+
+(defun setup-european-environment ()
+ (setq coding-category-iso-8-1 'coding-system-iso-8859-1)
+
+ (set-coding-priority
+ '(coding-category-iso-7
+ coding-category-iso-8-1
+ coding-category-iso-8-2))
+
+ (setq-default buffer-file-coding-system 'coding-system-iso-8859-1)
+ (set-terminal-coding-system 'coding-system-iso-8859-1)
+ (set-keyboard-coding-system 'coding-system-iso-8859-1)
+
+ (setq default-input-method '("European" . "quail-latin-1"))
+ )
+
+(set-language-info "English" 'tutorial "TUTORIAL")
+
+(register-input-method "French"
+ '("quail-latin-1" quail-use-package "quail/latin"))
+(register-input-method "French"
+ '("quail-latin-1" quail-use-package "quail/latin"))
+
+(set-language-info-alist
+ "European" '((setup-function . setup-european-environment)
+ (charset . (ascii latin-iso8859-1 latin-iso8859-2
+ latin-iso8859-3 latin-iso8859-4 latin-iso8859-9))
+ (coding-system . (coding-system-iso-8859-1
+ coding-system-iso-8859-2
+ coding-system-iso-8859-3
+ coding-system-iso-8859-4
+ coding-system-iso-8859-9))
+ (documentation . t)
+ (sample-text
+ . "Hello, Hej, Tere, Hei, Bonjour, Gr\e,A|_\e(B Gott, Ciao, \e,A!\e(BHola!")))
+
+;;; european.el ends here
--- /dev/null
+;;; greek.el --- Support for Greek
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: multilingual, Greek
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; For Greek, the character set ISO8859-7 is supported.
+
+;;; Code:
+
+(make-coding-system
+ 'coding-system-iso-8859-7 2 ?7 "MIME ISO-8859-7"
+ '((ascii t) (greek-iso8859-7 t) nil nil
+ nil ascii-eol ascii-cntl nil nil nil nil))
+
+(register-input-method
+ "Greek" '("quail-greek" quail-use-package "quail/greek"))
+
+(defun setup-greek-environment ()
+ (setq coding-category-iso-8-1 'coding-system-iso-8859-7)
+
+ (set-coding-priority
+ '(coding-category-iso-7
+ coding-category-iso-8-1))
+
+ (setq-default buffer-file-coding-system 'coding-system-iso-8859-7)
+ (set-terminal-coding-system 'coding-system-iso-8859-7)
+ (set-keyboard-coding-system 'coding-system-iso-8859-7)
+
+ (setq default-input-method '("Greek" . "quail-greek"))
+ )
+
+(set-language-info-alist
+ "Greek" '((setup-function . setup-greek-environment)
+ (charset . (greek-iso8859-7))
+ (coding-system . (coding-system-iso-8859-7))
+ (documentation . t)
+ (sample-text . "Greek (\e,FGkk]mija\e(B) \e,FCei\\e(B \e,Fsar\e(B")))
+
+;;; greek.el ends here
--- /dev/null
+;;; hebrew.el --- Support for Hebrew
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: multilingual, Hebrew
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; For Hebrew, the character sets ISO8859-8 is supported.
+
+;;; Code:
+
+(make-coding-system
+ 'coding-system-iso-8859-8 2 ?8 "MIME ISO-8859-8"
+ '((ascii t) (hebrew-iso8859-8 t) nil nil
+ nil ascii-eol ascii-cntl nil nil nil nil nil t))
+
+(register-input-method
+ "Hebrew" '("quail-hebrew" quail-use-package "quail/hebrew"))
+
+(defun setup-hebrew-environment ()
+ (setq coding-category-iso-8-1 'coding-system-iso-8859-8)
+
+ (set-coding-priority
+ '(coding-category-iso-7
+ coding-category-iso-8-1
+ coding-category-iso-8-2))
+
+ (setq-default buffer-file-coding-system 'coding-category-iso-8-2)
+ (set-terminal-coding-system 'coding-category-iso-8-2)
+ (set-keyboard-coding-system 'coding-category-iso-8-2)
+
+ (setq default-input-method '("Hebrew" . "quail-hebrew"))
+ )
+
+(set-language-info-alist
+ "Hebrew" '((setup-function . setup-hebrew-environment)
+ (charset . (hebrew-iso8859-8))
+ (coding-system . (coding-system-iso-8859-8))
+ (documentation . "Right-to-left writing is Not yet supported")
+ (sample-text . "Hebrew \e,Hylem\e(B")))
+
+;;; hebew.el ends here
--- /dev/null
+;;; indian.el --- Support for Indian Languages
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+
+;; Author: KAWABATA, Taichi <kawabata@is.s.u-tokyo.ac.jp>
+
+;; Keywords: multilingual, Indian
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; History:
+;; 1996.10.18 written by KAWABATA, Taichi <kawabata@is.s.u-tokyo.ac.jp>
+
+;; For Indian, the character set IS 13194 is supported.
+;;
+;; IS 13194 does not specifically assign glyphs for each characters.
+;; Following code is not specific to each Indian language.
+;;
+;; Eventually, this code will support generic information about
+;; following scripts.
+;;
+;; Devanagari
+;; Bengali
+;; Gurmukhi
+;; Gujarati
+;; Oriya
+;; Tamil
+;; Telgu
+;; Kannada
+;; Malayalam
+;;
+;; In this file, charsets other than charset-ascii and charset-indian-is13194
+;; should not be used except in the comment.
+
+;;; Code:
+
+;; Followings are what you see when you refer to the Emacs
+;; representations of IS 13194 charcters. However, this is merely
+;; tentative apperance, and you must convert them by
+;; indian-to-xxxxxx(specific script) function to use them.
+;; Devanagari is not an exception of this rule.
+
+;; 0xa0 //\e(5!"#$%&'()*+,-./\e(B
+;; 0xb0 \e(50123456789:;<=>?\e(B
+;; 0xc0 \e(5@ABCDEFGHIJKLMNO\e(B
+;; 0xd0 \e(5PQRSTUVWXYZ[\]^_\e(B
+;; 0xe0 \e(5`abcdefghijklmno\e(B
+;; 0xf0 \e(5pqrstuvwxyz{|}~\e(B//
+
+;; Note - In IS 13194, several symbols are obtained by special
+;; combination of several characters and Nukta sign.
+;;
+;; Sanskrit Vowel R -> \e(5*\e(B + \e(5i\e(B
+;; Sanskrit Vowel L -> \e(5&\e(B + \e(5i\e(B
+;; Sanskrit Vowel LL -> \e(5'\e(B + \e(5i\e(B
+;; Sanskrit Avagrah -> \e(5j\e(B + \e(5i\e(B
+;; OM -> \e(5!\e(B + \e(5i\e(B
+;;
+;; Note - IS 13194 defines ATR(0xEF) and EXT(0xF0), but they are
+;; not used in Emacs.
+;;
+;; Note - the above characters DO NOT represent any script. For
+;; example, if you want to obtain Devanagari character, you must do
+;; something like the following.
+;;
+;; (char-to-string (indian-to-devanagari ?\e(5$\e(B))
+;; "\e$(5!$\e(B"
+
+(let ((deflist
+ '(;; chars syntax category
+ ("\e(5!"#\e(B" "w" ?7) ; vowel-modifying diacritical mark
+ ; chandrabindu, anuswar, visarga
+ ("\e(5$\e(B-\e(52\e(B" "w" ?5) ; independent vowel
+ ("\e(53\e(B-\e(5X\e(B" "w" ?0) ; consonant
+ ("\e(5Z\e(B-\e(5g\e(B" "w" ?8) ; matra
+ ("\e(5q\e(B-\e(5z\e(B" "w" ?6) ; digit
+ ))
+ elm chars len syntax category to ch i)
+ (while deflist
+ (setq elm (car deflist))
+ (setq chars (car elm)
+ len (length chars)
+ syntax (nth 1 elm)
+ category (nth 2 elm)
+ i 0)
+ (while (< i len)
+ (if (= (aref chars i) ?-)
+ (setq i (1+ i)
+ to (sref chars i))
+ (setq ch (sref chars i)
+ to ch))
+ (while (<= ch to)
+ (modify-syntax-entry ch syntax)
+ (modify-category-entry ch category)
+ (setq ch (1+ ch)))
+ (setq i (+ i (char-bytes to))))
+ (setq deflist (cdr deflist))))
+
+
+;;; ITRANS
+;;
+;; ITRANS is one of the most popular method to exchange indian scripts
+;; electronically. Here is the table to convert between ITRANS code and
+;; IS 13194 code.
+
+(defvar indian-itrans-consonant-alist
+ '(
+ ("k" . "\e(53\e(B")
+ ("kh" . "\e(54\e(B")
+ ("g" . "\e(55\e(B")
+ ("gh" . "\e(56\e(B")
+ ("N^" . "\e(57\e(B")
+ ("ch" . "\e(58\e(B")
+ ("chh" . "\e(59\e(B")
+ ("j" . "\e(5:\e(B")
+ ("jh" . "\e(5;\e(B")
+ ("JN" . "\e(5<\e(B")
+ ("T" . "\e(5=\e(B")
+ ("Th" . "\e(5>\e(B")
+ ("D" . "\e(5?\e(B")
+ ("Dh" . "\e(5@\e(B")
+ ("N" . "\e(5A\e(B")
+ ("t" . "\e(5B\e(B")
+ ("th" . "\e(5C\e(B")
+ ("d" . "\e(5D\e(B")
+ ("dh" . "\e(5E\e(B")
+ ("n" . "\e(5F\e(B")
+ ("nh" . "\e(5G\e(B") ; For transcription of non-Devanagari Languages.
+ ("p" . "\e(5H\e(B")
+ ("ph" . "\e(5I\e(B")
+ ("b" . "\e(5J\e(B")
+ ("bh" . "\e(5K\e(B")
+ ("m" . "\e(5L\e(B")
+ ("y" . "\e(5M\e(B")
+ ("yh" . "\e(5N\e(B") ; For transcription of non-Devanagari Languages.
+ ("r" . "\e(5O\e(B")
+ ("rh" . "\e(5P\e(B") ; For transcription of non-Devanagari Languages.
+ ("l" . "\e(5Q\e(B")
+ ("v" . "\e(5T\e(B")
+ ("sh" . "\e(5U\e(B")
+ ("shh" . "\e(5V\e(B")
+ ("s" . "\e(5W\e(B")
+ ("h" . "\e(5X\e(B")
+ ("ld" . "\e(5R\e(B")
+ ("L" . "\e(5R\e(B")
+ ("ksh" . "\e$(5!3!h!V\e(B")
+ ("GY" . "***GY***") ; Must check out later.
+ ;; special consonants
+ ("q" . "\e(53i\e(B")
+ ("K" . "\e(54i\e(B")
+ ("G" . "\e(55i\e(B")
+ ("z" . "\e(5:i\e(B")
+ ("f" . "\e(5Ii\e(B")
+ (".D" . "\e(5?i\e(B")
+ (".Dh" . "\e(5@i\e(B")
+ ))
+
+(defvar indian-itrans-vowel-sign-alist
+ '(
+ ;; Special treatment unique to IS 13194 Transliteration
+ ("" . "\e(5h\e(B")
+ ("a" . "")
+ ;; Matra (Vowel Sign)
+ ("aa" . "\e(5Z\e(B")
+ ("A" . "\e(5Z\e(B")
+ ("i" . "\e(5[\e(B")
+ ("ii" . "\e(5\\e(B")
+ ("I" . "\e(5\\e(B")
+ ("u" . "\e(5]\e(B")
+ ("uu" . "\e(5^\e(B")
+ ("U" . "\e(5^\e(B")
+ ("R^i" . "\e(5_\e(B") ; These must be checked out later.
+ ("R^I" . "\e(5_i\e(B")
+ ("L^i" . "\e(5[i\e(B")
+ ("L^I" . "\e(5\i\e(B")
+ ("E" . "\e(5`\e(B") ; For transcription of non-Devanangri Languages.
+ ("e" . "\e(5a\e(B")
+ ("ai" . "\e(5b\e(B")
+ ;; ("e.c" . "\e(5c\e(B") ; Tentatively suppressed.
+ ("O" . "\e(5d\e(B") ; For transcription of non-Devanagari Languages.
+ ("o" . "\e(5e\e(B")
+ ("au" . "\e(5f\e(B")
+ ;; ("o.c" . "\e(5g\e(B") ; Tentatively suppressed.
+ ))
+
+;;
+;; Independent vowels and other signs.
+;;
+
+(defvar indian-itrans-other-letters-alist
+ '(
+ ("a" . "\e(5$\e(B")
+ ("aa" . "\e(5%\e(B")
+ ("A" . "\e(5%\e(B")
+ ("i" . "\e(5&\e(B")
+ ("ii" . "\e(5'\e(B")
+ ("I" . "\e(5'\e(B")
+ ("u" . "\e(5(\e(B")
+ ("uu" . "\e(5)\e(B")
+ ("U" . "\e(5)\e(B")
+ ("R^i" . "\e(5*\e(B")
+ ("R^I" . "\e(5*i\e(B")
+ ("L^i" . "\e(5&i\e(B")
+ ("L^I" . "\e(5'i\e(B")
+ ("E" . "\e(5+\e(B") ; For transcription of non-Devanagari Languages.
+ ("e" . "\e(5,\e(B")
+ ("ai" . "\e(5-\e(B")
+ ;; ("e.c" . "\e(5.\e(B") ; Candra E
+ ("O" . "\e(5/\e(B") ; For transcription of non-Devanagari Languages.
+ ("o" . "\e(50\e(B")
+ ("au" . "\e(51\e(B")
+ ;; ("o.c" . "\e(52\e(B") ; Candra O
+ ("M" . "\e(5$\e(B")
+ ("H" . "\e(5#\e(B")
+ ("AUM" . "\e(5!i\e(B")
+ ("OM" . "\e(5!i\e(B")
+ (".r" . "\e(5Oh\e(B")
+ (".n" . "\e(5"\e(B")
+ (".N" . "\e(5!\e(B")
+ (".h" . "\e(5h\e(B") ; Halant
+ (".." . "\e(5j\e(B")
+ (".a" . "\e(5ji\e(B") ; Avagrah
+ ("0" . "\e(5q\e(B")
+ ("1" . "\e(5r\e(B")
+ ("2" . "\e(5s\e(B")
+ ("3" . "\e(5t\e(B")
+ ("4" . "\e(5u\e(B")
+ ("5" . "\e(5v\e(B")
+ ("6" . "\e(5w\e(B")
+ ("7" . "\e(5x\e(B")
+ ("8" . "\e(5y\e(B")
+ ("9" . "\e(5z\e(B")
+ ))
+
+;; Regular expression matching single Indian character represented
+;; by ITRANS.
+
+(defvar indian-itrans-regexp
+ (let ((consonant "\\([cs]hh?\\)\\|[kgjTDnpbyr]h?\\|\\(N\\^?\\)\\|\\(jN\\)\\|[mvqKGzfs]\\|\\(ld?\\)\\|\\(ksh\\)\\|\\(GY\\)\\|\\(\\.Dh?\\)")
+ (vowel "\\(a[aiu]\\)\\|\\(ii\\)\\|\\(uu\\)\\|\\([RL]\\^[iI]\\)\\|[AIEOeoaiu]")
+ (misc "[MH0-9]\\|\\(AUM\\)\\|\\(OM\\)\\|\\(\\.[rnNh\\.a]\\)")
+ (lpre "\\(") (rpre "\\)") (orre "\\|"))
+ (concat lpre misc rpre orre
+ lpre lpre consonant rpre "?" lpre vowel rpre rpre orre
+ lpre consonant rpre )))
+
+;;
+;; Regular expression matching single ITRANS unit for IS 13194 characters.
+;;
+
+(defvar itrans-indian-regexp
+ (let ((vowel "[\e(5$\e(B-\e(52\e(B]")
+ (consonant "[\e(53\e(B-\e(5X\e(B]")
+ (vowel-sign "[\e(5Z\e(B-\e(5g\e(B]")
+ (misc "[\e(5q\e(B-\e(5z\e(B]")
+ (lpre "\\(") (rpre "\\)") (orre "\\|"))
+ nil)) ; not yet prepared.
+
+
+;;
+;; IS13194 - ITRANS conversion table for string matching above regexp.
+;;
+
+(defvar indian-itrans-alist
+ (let ((cl indian-itrans-consonant-alist)
+ (ml indian-itrans-other-letters-alist) rules)
+ (while cl
+ (let ((vl indian-itrans-vowel-sign-alist))
+ (while vl
+ (setq rules
+ (cons (cons (concat (car (car cl)) (car (car vl)))
+ (concat (cdr (car cl)) (cdr (car vl))))
+ rules))
+ (setq vl (cdr vl))))
+ (setq cl (cdr cl)))
+ (while ml
+ (setq rules (cons (cons (car (car ml))
+ (cdr (car ml)))
+ rules))
+ (setq ml (cdr ml)))
+ rules))
+
+;;
+;; Utility program to convert from ITRANS to IS 13194 in specified region.
+;;
+
+(defun indian-decode-itrans-region (from to)
+ "Convert `ITRANS' mnemonics of the current region to Indian characters.
+When called from a program, expects two arguments,
+positions (integers or markers) specifying the stretch of the region."
+ (interactive "r")
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (while (re-search-forward indian-itrans-regexp nil t)
+ (let* ((itrans (buffer-substring (match-beginning 0) (match-end 0)))
+ (ch (cdr (assoc itrans indian-itrans-alist))))
+ (if ch
+ (progn
+ (delete-region (match-beginning 0) (match-end 0))
+ (insert ch)))))
+ (goto-char (point-min))
+ (while (re-search-forward "\\(\e(5h\e(B\\)[^\\c0]" nil t)
+ (delete-region (match-beginning 1) (match-end 1)))))
+
+;;
+;; Utility program to convert from IS 13194 to ITRANS in specified region.
+;;
+
+;;;;;; not yet prepared.
+
+;;; indian.el ends here
--- /dev/null
+;; japan-util.el -- utilities for Japanese
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: mule, multilingual, Japanese
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Code:
+
+(defconst japanese-kana-table
+ '((?\e$B$"\e(B ?\e$B%"\e(B ?\e(I1\e(B) (?\e$B$$\e(B ?\e$B%$\e(B ?\e(I2\e(B) (?\e$B$&\e(B ?\e$B%&\e(B ?\e(I3\e(B) (?\e$B$(\e(B ?\e$B%(\e(B ?\e(I4\e(B) (?\e$B$*\e(B ?\e$B%*\e(B ?\e(I5\e(B)
+ (?\e$B$+\e(B ?\e$B%+\e(B ?\e(I6\e(B) (?\e$B$-\e(B ?\e$B%-\e(B ?\e(I7\e(B) (?\e$B$/\e(B ?\e$B%/\e(B ?\e(I8\e(B) (?\e$B$1\e(B ?\e$B%1\e(B ?\e(I9\e(B) (?\e$B$3\e(B ?\e$B%3\e(B ?\e(I:\e(B)
+ (?\e$B$5\e(B ?\e$B%5\e(B ?\e(I;\e(B) (?\e$B$7\e(B ?\e$B%7\e(B ?\e(I<\e(B) (?\e$B$9\e(B ?\e$B%9\e(B ?\e(I=\e(B) (?\e$B$;\e(B ?\e$B%;\e(B ?\e(I>\e(B) (?\e$B$=\e(B ?\e$B%=\e(B ?\e(I?\e(B)
+ (?\e$B$?\e(B ?\e$B%?\e(B ?\e(I@\e(B) (?\e$B$A\e(B ?\e$B%A\e(B ?\e(IA\e(B) (?\e$B$D\e(B ?\e$B%D\e(B ?\e(IB\e(B) (?\e$B$F\e(B ?\e$B%F\e(B ?\e(IC\e(B) (?\e$B$H\e(B ?\e$B%H\e(B ?\e(ID\e(B)
+ (?\e$B$J\e(B ?\e$B%J\e(B ?\e(IE\e(B) (?\e$B$K\e(B ?\e$B%K\e(B ?\e(IF\e(B) (?\e$B$L\e(B ?\e$B%L\e(B ?\e(IG\e(B) (?\e$B$M\e(B ?\e$B%M\e(B ?\e(IH\e(B) (?\e$B$N\e(B ?\e$B%N\e(B ?\e(II\e(B)
+ (?\e$B$O\e(B ?\e$B%O\e(B ?\e(IJ\e(B) (?\e$B$R\e(B ?\e$B%R\e(B ?\e(IK\e(B) (?\e$B$U\e(B ?\e$B%U\e(B ?\e(IL\e(B) (?\e$B$X\e(B ?\e$B%X\e(B ?\e(IM\e(B) (?\e$B$[\e(B ?\e$B%[\e(B ?\e(IN\e(B)
+ (?\e$B$^\e(B ?\e$B%^\e(B ?\e(IO\e(B) (?\e$B$_\e(B ?\e$B%_\e(B ?\e(IP\e(B) (?\e$B$`\e(B ?\e$B%`\e(B ?\e(IQ\e(B) (?\e$B$a\e(B ?\e$B%a\e(B ?\e(IR\e(B) (?\e$B$b\e(B ?\e$B%b\e(B ?\e(IS\e(B)
+ (?\e$B$d\e(B ?\e$B%d\e(B ?\e(IT\e(B) (?\e$B$f\e(B ?\e$B%f\e(B ?\e(IU\e(B) (?\e$B$h\e(B ?\e$B%h\e(B ?\e(IV\e(B)
+ (?\e$B$i\e(B ?\e$B%i\e(B ?\e(IW\e(B) (?\e$B$j\e(B ?\e$B%j\e(B ?\e(IX\e(B) (?\e$B$k\e(B ?\e$B%k\e(B ?\e(IY\e(B) (?\e$B$l\e(B ?\e$B%l\e(B ?\e(IZ\e(B) (?\e$B$m\e(B ?\e$B%m\e(B ?\e(I[\e(B)
+ (?\e$B$o\e(B ?\e$B%o\e(B ?\e(I\\e(B) (?\e$B$p\e(B ?\e$B%p\e(B nil) (?\e$B$q\e(B ?\e$B%q\e(B nil) (?\e$B$r\e(B ?\e$B%r\e(B ?\e(I&\e(B)
+ (?\e$B$s\e(B ?\e$B%s\e(B ?\e(I]\e(B)
+ (?\e$B$,\e(B ?\e$B%,\e(B "\e(I6^\e(B") (?\e$B$.\e(B ?\e$B%.\e(B "\e(I7^\e(B") (?\e$B$0\e(B ?\e$B%0\e(B "\e(I8^\e(B") (?\e$B$2\e(B ?\e$B%2\e(B "\e(I9^\e(B") (?\e$B$4\e(B ?\e$B%4\e(B "\e(I:^\e(B")
+ (?\e$B$6\e(B ?\e$B%6\e(B "\e(I;^\e(B") (?\e$B$8\e(B ?\e$B%8\e(B "\e(I<^\e(B") (?\e$B$:\e(B ?\e$B%:\e(B "\e(I=^\e(B") (?\e$B$<\e(B ?\e$B%<\e(B "\e(I>^\e(B") (?\e$B$>\e(B ?\e$B%>\e(B "\e(I?^\e(B")
+ (?\e$B$@\e(B ?\e$B%@\e(B "\e(I@^\e(B") (?\e$B$B\e(B ?\e$B%B\e(B "\e(IA^\e(B") (?\e$B$E\e(B ?\e$B%E\e(B "\e(IB^\e(B") (?\e$B$G\e(B ?\e$B%G\e(B "\e(IC^\e(B") (?\e$B$I\e(B ?\e$B%I\e(B "\e(ID^\e(B")
+ (?\e$B$P\e(B ?\e$B%P\e(B "\e(IJ^\e(B") (?\e$B$S\e(B ?\e$B%S\e(B "\e(IK^\e(B") (?\e$B$V\e(B ?\e$B%V\e(B "\e(IL^\e(B") (?\e$B$Y\e(B ?\e$B%Y\e(B "\e(IM^\e(B") (?\e$B$\\e(B ?\e$B%\\e(B "\e(IN^\e(B")
+ (?\e$B$Q\e(B ?\e$B%Q\e(B "\e(IJ_\e(B") (?\e$B$T\e(B ?\e$B%T\e(B "\e(IK_\e(B") (?\e$B$W\e(B ?\e$B%W\e(B "\e(IL_\e(B") (?\e$B$Z\e(B ?\e$B%Z\e(B "\e(IM_\e(B") (?\e$B$]\e(B ?\e$B%]\e(B "\e(IN_\e(B")
+ (?\e$B$!\e(B ?\e$B%!\e(B ?\e(I'\e(B) (?\e$B$#\e(B ?\e$B%#\e(B ?\e(I(\e(B) (?\e$B$%\e(B ?\e$B%%\e(B ?\e(I)\e(B) (?\e$B$'\e(B ?\e$B%'\e(B ?\e(I*\e(B) (?\e$B$)\e(B ?\e$B%)\e(B ?\e(I+\e(B)
+ (?\e$B$C\e(B ?\e$B%C\e(B ?\e(I/\e(B)
+ (?\e$B$c\e(B ?\e$B%c\e(B ?\e(I,\e(B) (?\e$B$e\e(B ?\e$B%e\e(B ?\e(I-\e(B) (?\e$B$g\e(B ?\e$B%g\e(B ?\e(I.\e(B)
+ (?\e$B$n\e(B ?\e$B%n\e(B nil)
+ (nil ?\e$B%t\e(B "\e(I3^\e(B") (nil ?\e$B%u\e(B nil) (nil ?\e$B%v\e(B nil))
+ "Japanese JISX0208 Kana character table.
+Each element is of the form (HIRAGANA KATAKANA HANKAKU-KATAKANA), where
+HIRAGANA and KATAKANA belong to `japanese-jisx0208',
+HANKAKU-KATAKANA belongs to `japanese-jisx0201-kana'.")
+
+;; Put properties 'katakana, 'hiragana, and 'jix0201 to each Japanese
+;; kana characters for conversion among them.
+(let ((l japanese-kana-table)
+ slot hiragana katakana jisx0201)
+ (while l
+ (setq slot (car l)
+ hiragana (car slot) katakana (nth 1 slot) jisx0201 (nth 2 slot)
+ l (cdr l))
+ (if hiragana
+ (progn
+ (put-char-code-property hiragana 'katakana katakana)
+ (put-char-code-property katakana 'hiragana hiragana)
+ (if jisx0201
+ (progn
+ (put-char-code-property hiragana 'jisx0201 jisx0201)
+ (if (integerp jisx0201)
+ (put-char-code-property jisx0201 'hiragana hiragana))))))
+ (if jisx0201
+ (progn
+ (put-char-code-property katakana 'jisx0201 jisx0201)
+ (if (integerp jisx0201)
+ (put-char-code-property jisx0201 'katakana katakana))))))
+
+(defconst japanese-symbol-table
+ '((?\\e$B!!\e(B ?\ ) (?\e$B!"\e(B ?, ?\e(I$\e(B) (?\e$B!#\e(B ?. ?\e(I!\e(B) (?\e$B!$\e(B ?, ?\e(I$\e(B) (?\e$B!%\e(B ?. ?\e(I!\e(B) (?\e$B!&\e(B nil ?\e(I%\e(B)
+ (?\e$B!'\e(B ?:) (?\e$B!(\e(B ?\;) (?\e$B!)\e(B ??) (?\e$B!*\e(B ?!) (?\e$B!+\e(B nil ?\e(I^\e(B) (?\e$B!,\e(B nil ?\e(I_\e(B)
+ (?\e$B!-\e(B ?') (?\e$B!.\e(B ?`) (?\e$B!0\e(B ?^) (?\e$B!2\e(B ?_) (?\e$B!<\e(B ?-) (?\e$B!=\e(B ?-) (?\e$B!>\e(B ?-)
+ (?\e$B!?\e(B ?/) (?\e$B!@\e(B ?\\) (?\e$B!A\e(B ?~) (?\e$B!C\e(B ?|) (?\e$B!F\e(B ?`) (?\e$B!G\e(B ?') (?\e$B!H\e(B ?\") (?\e$B!I\e(B ?\")
+ (?\\e$B!J\e(B ?\() (?\\e$B!K\e(B ?\)) (?\\e$B!N\e(B ?[) (?\\e$B!O\e(B ?]) (?\\e$B!P\e(B ?{) (?\\e$B!Q\e(B ?})
+ (?\e$B!R\e(B ?<) (?\e$B!S\e(B ?>) (?\e$B!\\e(B ?+) (?\e$B!]\e(B ?-) (?\e$B!a\e(B ?=) (?\e$B!c\e(B ?<) (?\e$B!d\e(B ?>)
+ (?\e$B!l\e(B ?') (?\e$B!m\e(B ?\") (?\e$B!o\e(B ?\\) (?\e$B!p\e(B ?$) (?\e$B!s\e(B ?%) (?\e$B!t\e(B ?#) (?\e$B!u\e(B ?&) (?\e$B!v\e(B ?*)
+ (?\e$B!w\e(B ?@))
+ "Japanese JISX0208 symbol character table.
+ Each element is of the form (SYMBOL ASCII HANKAKU), where SYMBOL
+belongs to `japanese-jisx0208', ASCII belongs to `ascii', and HANKAKU
+belongs to `japanese-jisx0201-kana'.")
+
+;; Put properties 'jisx0208, 'jisx0201, and 'ascii to each Japanese
+;; symbol and ASCII characters for conversion among them.
+(let ((l japanese-symbol-table)
+ slot jisx0208 ascii jisx0201)
+ (while l
+ (setq slot (car l)
+ jisx0208 (car slot) ascii (nth 1 slot) jisx0201 (nth 2 slot)
+ l (cdr l))
+ (if ascii
+ (progn
+ (put-char-code-property jisx0208 'ascii ascii)
+ (put-char-code-property ascii 'jisx0208 jisx0208)))
+ (if jisx0201
+ (progn
+ (put-char-code-property jisx0208 'jisx0201 jisx0201)
+ (put-char-code-property jisx0201 'jisx0208 jisx0208)))))
+
+(defconst japanese-alpha-numeric-table
+ '((?\e$B#0\e(B . ?0) (?\e$B#1\e(B . ?1) (?\e$B#2\e(B . ?2) (?\e$B#3\e(B . ?3) (?\e$B#4\e(B . ?4)
+ (?\e$B#5\e(B . ?5) (?\e$B#6\e(B . ?6) (?\e$B#7\e(B . ?7) (?\e$B#8\e(B . ?8) (?\e$B#9\e(B . ?9)
+ (?\e$B#A\e(B . ?A) (?\e$B#B\e(B . ?B) (?\e$B#C\e(B . ?C) (?\e$B#D\e(B . ?D) (?\e$B#E\e(B . ?E)
+ (?\e$B#F\e(B . ?F) (?\e$B#G\e(B . ?G) (?\e$B#H\e(B . ?H) (?\e$B#I\e(B . ?I) (?\e$B#J\e(B . ?J)
+ (?\e$B#K\e(B . ?K) (?\e$B#L\e(B . ?L) (?\e$B#M\e(B . ?M) (?\e$B#N\e(B . ?N) (?\e$B#O\e(B . ?O)
+ (?\e$B#P\e(B . ?P) (?\e$B#Q\e(B . ?Q) (?\e$B#R\e(B . ?R) (?\e$B#S\e(B . ?S) (?\e$B#T\e(B . ?T)
+ (?\e$B#U\e(B . ?U) (?\e$B#V\e(B . ?V) (?\e$B#W\e(B . ?W) (?\e$B#X\e(B . ?X) (?\e$B#Y\e(B . ?Y) (?\e$B#Z\e(B . ?Z)
+ (?\e$B#a\e(B . ?a) (?\e$B#b\e(B . ?b) (?\e$B#c\e(B . ?c) (?\e$B#d\e(B . ?d) (?\e$B#e\e(B . ?e)
+ (?\e$B#f\e(B . ?f) (?\e$B#g\e(B . ?g) (?\e$B#h\e(B . ?h) (?\e$B#i\e(B . ?i) (?\e$B#j\e(B . ?j)
+ (?\e$B#k\e(B . ?k) (?\e$B#l\e(B . ?l) (?\e$B#m\e(B . ?m) (?\e$B#n\e(B . ?n) (?\e$B#o\e(B . ?o)
+ (?\e$B#p\e(B . ?p) (?\e$B#q\e(B . ?q) (?\e$B#r\e(B . ?r) (?\e$B#s\e(B . ?s) (?\e$B#t\e(B . ?t)
+ (?\e$B#u\e(B . ?u) (?\e$B#v\e(B . ?v) (?\e$B#w\e(B . ?w) (?\e$B#x\e(B . ?x) (?\e$B#y\e(B . ?y) (?\e$B#z\e(B . ?z))
+ "Japanese JISX0208 alpha numeric character table.
+Each element is of the form (ALPHA-NUMERIC ASCII), where ALPHA-NUMERIC
+belongs to `japanese-jisx0208', ASCII belongs to `ascii'.")
+
+;; Put properties 'jisx0208 and 'ascii to each Japanese alpha numeric
+;; and ASCII characters for conversion between them.
+(let ((l japanese-alpha-numeric-table)
+ slot jisx0208 ascii)
+ (while l
+ (setq slot (car l)
+ jisx0208 (car slot) ascii (cdr slot)
+ l (cdr l))
+ (put-char-code-property jisx0208 'ascii ascii)
+ (put-char-code-property ascii 'jisx0208 jisx0208)))
+
+;; Convert string STR by FUNC and return a resulting string.
+(defun japanese-string-conversion (str func &rest args)
+ (let ((buf (get-buffer-create " *Japanese work*")))
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer)
+ (insert str)
+ (apply func 1 (point) args)
+ (buffer-string))))
+
+;;;###autoload
+(defun japanese-katakana (obj &optional hankaku)
+ "Convert argument to Katakana and return that.
+The argument may be a character or string. The result has the same type.
+The argument object is not altered--the value is a copy.
+Optional argument HANKAKU t means to convert to `hankaku' Katakana
+ \(`japanese-jisx0201-kana'), in which case return value
+ may be a string even if OBJ is a character if two Katakanas are
+ necessary to represent OBJ."
+ (if (stringp obj)
+ (japanese-string-conversion obj 'japanese-katakana-region hankaku)
+ (or (get-char-code-property obj (if hankaku 'jisx0201 'katakana))
+ obj)))
+
+;;;###autoload
+(defun japanese-hiragana (obj)
+ "Convert argument to Hiragana and return that.
+The argument may be a character or string. The result has the same type.
+The argument object is not altered--the value is a copy."
+ (if (stringp obj)
+ (japanese-string-conversion obj 'japanese-hiragana-region)
+ (or (get-char-code-property obj 'hiragana)
+ obj)))
+
+;;;###autoload
+(defun japanese-hankaku (obj &optional ascii-only)
+ "Convert argument to `hankaku' and return that.
+The argument may be a character or string. The result has the same type.
+The argument object is not altered--the value is a copy.
+Optional argument ASCII-ONLY non-nil means to return only ASCII character."
+ (if (stringp obj)
+ (japanese-string-conversion obj 'japanese-hankaku-region ascii-only)
+ (or (get-char-code-property obj 'ascii)
+ (and (not ascii-only)
+ (get-char-code-property obj 'jisx0201))
+ obj)))
+
+;;;###autoload
+(defun japanese-zenkaku (obj)
+ "Convert argument to `zenkaku' and return that.
+The argument may be a character or string. The result has the same type.
+The argument object is not altered--the value is a copy."
+ (if (stringp obj)
+ (japanese-string-conversion obj 'japanese-zenkaku-region)
+ (or (get-char-code-property obj 'jisx0208)
+ obj)))
+
+;;;###autoload
+(defun japanese-katakana-region (from to &optional hankaku)
+ "Convert Japanese `hiragana' chars in the region to `katakana' chars.
+Optional argument HANKAKU t means to convert to `hankaku katakana' character
+of which charset is `japanese-jisx0201-kana'."
+ (interactive "r\nP")
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (while (re-search-forward "\\cH\\|\\cK" nil t)
+ (let* ((hira (preceding-char))
+ (kata (japanese-katakana hira hankaku)))
+ (if kata
+ (progn
+ (delete-region (match-beginning 0) (match-end 0))
+ (insert kata)))))))
+
+;;;###autoload
+(defun japanese-hiragana-region (from to)
+ "Convert Japanese `katakana' chars in the region to `hiragana' chars."
+ (interactive "r")
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (while (re-search-forward "\\cK\\|\\ck" nil t)
+ (let* ((kata (preceding-char))
+ (hira (japanese-hiragana kata)))
+ (if hira
+ (progn
+ (delete-region (match-beginning 0) (match-end 0))
+ (insert hira)))))))
+
+;;;###autoload
+(defun japanese-hankaku-region (from to &optional ascii-only)
+ "Convert Japanese `zenkaku' chars in the region to `hankaku' chars.
+`Zenkaku' chars belong to `japanese-jisx0208'
+`Hankaku' chars belong to `ascii' or `japanese-jisx0201-kana'.
+Optional argument ASCII-ONLY non-nil means to convert only to ASCII char."
+ (interactive "r\nP")
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (while (re-search-forward "\\cj" nil t)
+ (let* ((zenkaku (preceding-char))
+ (hankaku (japanese-hankaku zenkaku ascii-only)))
+ (if hankaku
+ (progn
+ (delete-region (match-beginning 0) (match-end 0))
+ (insert hankaku)))))))
+
+;;;###autoload
+(defun japanese-zenkaku-region (from to)
+ "Convert hankaku' chars in the region to Japanese `zenkaku' chars.
+`Zenkaku' chars belong to `japanese-jisx0208'
+`Hankaku' chars belong to `ascii' or `japanese-jisx0201-kana'."
+ (interactive "r")
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (while (re-search-forward "\\ca\\|\\ck" nil t)
+ (let* ((hankaku (preceding-char))
+ (zenkaku (japanese-zenkaku hankaku)))
+ (if zenkaku
+ (progn
+ (delete-region (match-beginning 0) (match-end 0))
+ (insert zenkaku)))))))
+
+;;;###autoload
+(defun read-hiragana-string (prompt &optional initial-input)
+ "Read a Hiragana string from the minibuffer, prompting with string PROMPT.
+If non-nil, second arg INITIAL-INPUT is a string to insert before reading."
+ (read-multilingual-string prompt initial-input
+ "Japanese" "quail-ja-hiragana"))
+
+;;
+(provide 'language/japan-util)
+
+;;; Local Variables:
+;;; generated-autoload-file: "../loaddefs.el"
+;;; End:
+;;; japan-util.el ends here
--- /dev/null
+;;; japanese.el --- Japanese support
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: multilingual, Japanese
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; For Japanese, character sets JISX0201, JISX0208, JISX0212 are
+;; supported.
+
+;;; Code:
+
+(make-coding-system
+ 'coding-system-sjis 1 ?S
+ "Coding-system of Shift-JIS used in Japan." t)
+
+;; ISO-2022-JP and JUNET are aliases for ISO-2022-7.
+(put 'coding-system-iso-2022-jp 'coding-system 'coding-system-iso-2022-7)
+(put 'coding-system-junet 'coding-system 'coding-system-iso-2022-7)
+
+(make-coding-system
+ 'coding-system-old-jis 2 ?J
+ "Coding-system used for old jis terminal."
+ '((ascii t) nil nil nil
+ short ascii-eol ascii-cntl seven nil nil use-roman use-oldjis))
+
+(make-coding-system
+ 'coding-system-euc-japan 2 ?E
+ "Coding-system of Japanese EUC (Extended Unix Code)."
+ '(ascii japanese-jisx0208 katakana-jisx0201 japanese-jisx0212
+ short ascii-eol ascii-cntl nil nil single-shift))
+
+(register-input-method
+ "Japanese" '("quail-ja" quail-use-package "quail/japanese"))
+
+(register-input-method
+ "Japanese" '("quail-ja-hiragana" quail-use-package "quail/japanese"))
+
+(defun setup-japanese-environment ()
+ (interactive)
+ (setq coding-category-iso-8-2 'coding-system-euc-japan)
+
+ (set-coding-priority
+ '(coding-category-iso-7
+ coding-category-iso-8-2
+ coding-category-sjis
+ coding-category-iso-8-1
+ coding-category-iso-else
+ coding-category-internal))
+
+ (if (eq system-type 'ms-dos)
+ (progn
+ (setq-default buffer-file-coding-system 'coding-system-sjis)
+ (set-terminal-coding-system 'coding-system-sjis)
+ (set-keyboard-coding-system 'coding-system-sjis)
+ (setq default-process-coding-system
+ '(coding-system-sjis-dos . coding-system-sjis-dos)))
+ (setq-default buffer-file-coding-system 'coding-system-iso-2022-jp)
+ (set-terminal-coding-system 'coding-system-iso-2022-jp)
+ (set-keyboard-coding-system 'coding-system-iso-2022-jp))
+
+ (set-default-input-method "Japanese" "quail-ja")
+ )
+
+(set-language-info-alist
+ "Japanese" '((setup-function . setup-japanese-environment)
+ (tutorial . "TUTORIAL.jp")
+ (charset . (japanese-jisx0208 japanese-jisx0208-1978
+ japanese-jisx0212 latin-jisx0201
+ katakana-jisx0201))
+ (coding-system . (coding-system-euc-japan
+ coding-system-sjis
+ coding-system-old-jis
+ coding-system-iso-2022-jp))
+ (documentation . t)
+ (sample-text . "Japanese (\e$BF|K\8l\e(B) \e$B$3$s$K$A$O\e(B, \e(I:]FAJ\e(B")))
+
+;;; japanese.el ends here
--- /dev/null
+;;; korean.el --- Support for Korean
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: multilingual, Korean
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; For Korean, the character set KSC5601 is supported.
+
+;;; Code:
+
+(make-coding-system
+ 'coding-system-euc-korea 2 ?K
+ "Coding-system of Korean EUC (Extended Unix Code)."
+ '((ascii t) korean-ksc5601 nil nil
+ nil ascii-eol ascii-cntl))
+
+;; EUC-KR is an alias for EUC-KOREA.
+(put 'coding-system-euc-kr 'coding-system 'coding-system-euc-korea)
+
+(make-coding-system
+ 'coding-system-iso-2022-kr 2 ?k
+ "Coding-System used for communication with mail in Korea."
+ '(ascii (nil korean-ksc5601) nil nil
+ nil ascii-eol ascii-cntl seven locking-shift))
+
+(register-input-method
+ "Korean" '("quail-hangul" quail-use-package "quail/hangul"))
+(register-input-method
+ "Korean" '("quail-hangul3" quail-use-package "quail/hangul3"))
+(register-input-method
+ "Korean" '("quail-hanja" quail-use-package "quail/hanja"))
+(register-input-method
+ "Korean" '("quail-symbol-ksc" quail-use-package "quail/symbol-ksc"))
+(register-input-method
+ "Korean" '("quail-hanja-jis" quail-use-package "quail/hanja-jis"))
+
+(defun setup-korean-environment ()
+ (setq coding-category-iso-8-2 'coding-system-euc-korea)
+
+ (set-coding-priority
+ '(coding-category-iso-7
+ coding-category-iso-8-2
+ coding-category-iso-8-1))
+
+ (setq-default buffer-file-coding-system 'coding-system-euc-korea)
+
+ (setq default-input-method '("Korean" . "quail-hangul"))
+ )
+
+(set-language-info-alist
+ "Korean" '((setup-function . setup-korean-environment)
+ (tutorial . "TUTORIAL.kr")
+ (charset . (korean-ksc5601))
+ (coding-system . (coding-system-euc-korea
+ coding-system-iso-2022-kr))
+ (documentation . t)
+ (sample-text . "Hangul (\e$(CGQ1[\e(B) \e$(C>H3gGO<<?d\e(B, \e$(C>H3gGO=J4O1n\e(B")))
+
+;;; korean.el ends here
--- /dev/null
+;;; misc-lang.el --- support for miscellaneous languages (characters)
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: multilingual, character set, coding system
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; IPA (International Phonetic Alphabet)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(register-input-method
+ "IPA" '("quail-ipa" quail-use-package "quail/ipa"))
+
+;;; misc-lang.el ends here
--- /dev/null
+;; thai-util.el -- utilities for Thai
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: mule, multilingual, thai
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Code:
+
+;; Setting information of Thai characters.
+
+(let ((l '((?\e,T!\e(B consonant "LETTER KO KAI") ; 0xA1
+ (?\e,T"\e(B consonant "LETTER KHO KHAI") ; 0xA2
+ (?\e,T#\e(B consonant "LETTER KHO KHUAT") ; 0xA3
+ (?\e,T$\e(B consonant "LETTER KHO KHWAI") ; 0xA4
+ (?\e,T%\e(B consonant "LETTER KHO KHON") ; 0xA5
+ (?\e,T&\e(B consonant "LETTER KHO RAKHANG") ; 0xA6
+ (?\e,T'\e(B consonant "LETTER NGO NGU") ; 0xA7
+ (?\e,T(\e(B consonant "LETTER CHO CHAN") ; 0xA8
+ (?\e,T)\e(B consonant "LETTER CHO CHING") ; 0xA9
+ (?\e,T*\e(B consonant "LETTER CHO CHANG") ; 0xAA
+ (?\e,T+\e(B consonant "LETTER SO SO") ; 0xAB
+ (?\e,T,\e(B consonant "LETTER CHO CHOE") ; 0xAC
+ (?\e,T-\e(B consonant "LETTER YO YING") ; 0xAD
+ (?\e,T.\e(B consonant "LETTER DO CHADA") ; 0xAE
+ (?\e,T/\e(B consonant "LETTER TO PATAK") ; 0xAF
+ (?\e,T0\e(B consonant "LETTER THO THAN") ; 0xB0
+ (?\e,T1\e(B consonant "LETTER THO NANGMONTHO") ; 0xB1
+ (?\e,T2\e(B consonant "LETTER THO PHUTHAO") ; 0xB2
+ (?\e,T3\e(B consonant "LETTER NO NEN") ; 0xB3
+ (?\e,T4\e(B consonant "LETTER DO DEK") ; 0xB4
+ (?\e,T5\e(B consonant "LETTER TO TAO") ; 0xB5
+ (?\e,T6\e(B consonant "LETTER THO THUNG") ; 0xB6
+ (?\e,T7\e(B consonant "LETTER THO THAHAN") ; 0xB7
+ (?\e,T8\e(B consonant "LETTER THO THONG") ; 0xB8
+ (?\e,T9\e(B consonant "LETTER NO NU") ; 0xB9
+ (?\e,T:\e(B consonant "LETTER BO BAIMAI") ; 0xBA
+ (?\e,T;\e(B consonant "LETTER PO PLA") ; 0xBB
+ (?\e,T<\e(B consonant "LETTER PHO PHUNG") ; 0xBC
+ (?\e,T=\e(B consonant "LETTER FO FA") ; 0xBD
+ (?\e,T>\e(B consonant "LETTER PHO PHAN") ; 0xBE
+ (?\e,T?\e(B consonant "LETTER FO FAN") ; 0xBF
+ (?\e,T@\e(B consonant "LETTER PHO SAMPHAO") ; 0xC0
+ (?\e,TA\e(B consonant "LETTER MO MA") ; 0xC1
+ (?\e,TB\e(B consonant "LETTER YO YAK") ; 0xC2
+ (?\e,TC\e(B consonant "LETTER RO RUA") ; 0xC3
+ (?\e,TD\e(B vowel-base "LETTER RU (Pali vowel letter)") ; 0xC4
+ (?\e,TE\e(B consonant "LETTER LO LING") ; 0xC5
+ (?\e,TF\e(B vowel-base "LETTER LU (Pali vowel letter)") ; 0xC6
+ (?\e,TG\e(B consonant "LETTER WO WAEN") ; 0xC7
+ (?\e,TH\e(B consonant "LETTER SO SALA") ; 0xC8
+ (?\e,TI\e(B consonant "LETTER SO RUSI") ; 0xC9
+ (?\e,TJ\e(B consonant "LETTER SO SUA") ; 0xCA
+ (?\e,TK\e(B consonant "LETTER HO HIP") ; 0xCB
+ (?\e,TL\e(B consonant "LETTER LO CHULA") ; 0xCC
+ (?\e,TM\e(B consonant "LETTER O ANG") ; 0xCD
+ (?\e,TN\e(B consonant "LETTER HO NOK HUK") ; 0xCE
+ (?\e,TO\e(B special "PAI YAN NOI (abbreviation)") ; 0xCF
+ (?\e,TP\e(B vowel-base "VOWEL SIGN SARA A") ; 0xD0
+ (?\e,TQ\e(B vowel-upper "VOWEL SIGN MAI HAN-AKAT N/S-T") ; 0xD1
+ (?\e,TR\e(B vowel-base "VOWEL SIGN SARA AA") ; 0xD2
+ (?\e,TS\e(B vowel-base "VOWEL SIGN SARA AM") ; 0xD3
+ (?\e,TT\e(B vowel-upper "VOWEL SIGN SARA I N/S-T") ; 0xD4
+ (?\e,TU\e(B vowel-upper "VOWEL SIGN SARA II N/S-T") ; 0xD5
+ (?\e,TV\e(B vowel-upper "VOWEL SIGN SARA UE N/S-T") ; 0xD6
+ (?\e,TW\e(B vowel-upper "VOWEL SIGN SARA UEE N/S-T") ; 0xD7
+ (?\e,TX\e(B vowel-lower "VOWEL SIGN SARA U N/S-B") ; 0xD8
+ (?\e,TY\e(B vowel-lower "VOWEL SIGN SARA UU N/S-B") ; 0xD9
+ (?\e,TZ\e(B vowel-lower "VOWEL SIGN PHINTHU N/S-B (Pali virama)") ; 0xDA
+ (?\e,T[\e(B invalid nil) ; 0xDA
+ (?\e,T\\e(B invalid nil) ; 0xDC
+ (?\e,T]\e(B invalid nil) ; 0xDC
+ (?\e,T^\e(B invalid nil) ; 0xDC
+ (?\e,T_\e(B special "BAHT SIGN (currency symbol)") ; 0xDF
+ (?\e,T`\e(B vowel-base "VOWEL SIGN SARA E") ; 0xE0
+ (?\e,Ta\e(B vowel-base "VOWEL SIGN SARA AE") ; 0xE1
+ (?\e,Tb\e(B vowel-base "VOWEL SIGN SARA O") ; 0xE2
+ (?\e,Tc\e(B vowel-base "VOWEL SIGN SARA MAI MUAN") ; 0xE3
+ (?\e,Td\e(B vowel-base "VOWEL SIGN SARA MAI MALAI") ; 0xE4
+ (?\e,Te\e(B vowel-base "LAK KHANG YAO") ; 0xE5
+ (?\e,Tf\e(B special "MAI YAMOK (repetion)") ; 0xE6
+ (?\e,Tg\e(B vowel-upper "VOWEL SIGN MAI TAI KHU N/S-T") ; 0xE7
+ (?\e,Th\e(B tone "TONE MAI EK N/S-T") ; 0xE8
+ (?\e,Ti\e(B tone "TONE MAI THO N/S-T") ; 0xE9
+ (?\e,Tj\e(B tone "TONE MAI TRI N/S-T") ; 0xEA
+ (?\e,Tk\e(B tone "TONE MAI CHATTAWA N/S-T") ; 0xEB
+ (?\e,Tl\e(B tone "THANTHAKHAT N/S-T (cancellation mark)") ; 0xEC
+ (?\e,Tm\e(B tone "NIKKHAHIT N/S-T (final nasal)") ; 0xED
+ (?\e,Tn\e(B vowel-upper "YAMAKKAN N/S-T") ; 0xEE
+ (?\e,To\e(B special "FONRMAN") ; 0xEF
+ (?\e,Tp\e(B special "DIGIT ZERO") ; 0xF0
+ (?\e,Tq\e(B special "DIGIT ONE") ; 0xF1
+ (?\e,Tr\e(B special "DIGIT TWO") ; 0xF2
+ (?\e,Ts\e(B special "DIGIT THREE") ; 0xF3
+ (?\e,Tt\e(B special "DIGIT FOUR") ; 0xF4
+ (?\e,Tu\e(B special "DIGIT FIVE") ; 0xF5
+ (?\e,Tv\e(B special "DIGIT SIX") ; 0xF6
+ (?\e,Tw\e(B special "DIGIT SEVEN") ; 0xF7
+ (?\e,Tx\e(B special "DIGIT EIGHT") ; 0xF8
+ (?\e,Ty\e(B special "DIGIT NINE") ; 0xF9
+ (?\e,Tz\e(B special "ANGKHANKHU (ellipsis)") ; 0xFA
+ (?\e,T{\e(B special "KHOMUT (beginning of religious texts)") ; 0xFB
+ (?\e,T|\e(B invalid nil) ; 0xFC
+ (?\e,T}\e(B invalid nil) ; 0xFD
+ (?\e,T~\e(B invalid nil) ; 0xFE
+ ))
+ elm)
+ (while l
+ (setq elm (car l))
+ (put-char-code-property (car elm) 'phonetic-type (car (cdr elm)))
+ (put-char-code-property (car elm) 'name (nth 2 elm))
+ (setq l (cdr l))))
+
+;;;###autoload
+(defun thai-compose-region (beg end)
+ "Compose Thai characters in the region.
+When called from a program, expects two arguments,
+positions (integers or markers) specifying the region."
+ (interactive "r")
+ (save-restriction
+ (narrow-to-region beg end)
+ (decompose-region (point-min) (point-max))
+ (goto-char (point-min))
+ (while (re-search-forward "\\c0\\(\\c2\\|\\c3\\|\\c4\\)+" nil t)
+ (if (aref (char-category-set (char-after (match-beginning 0))) ?t)
+ (compose-region (match-beginning 0) (match-end 0))))))
+
+;;;###autoload
+(defun thai-compose-buffer ()
+ "Compose Thai characters in the current buffer."
+ (interactive)
+ (thai-compose-region (point-min) (point-max)))
+
+;;;###autoload
+(defun thai-post-read-conversion (len)
+ (save-excursion
+ (save-restriction
+ (let ((buffer-modified-p (buffer-modified-p)))
+ (narrow-to-region (point) (+ (point) len))
+ (thai-compose-region (point-min) (point-max))
+ (set-buffer-modified-p buffer-modified-p)
+ (point-max)))))
+
+;;;###autoload
+(defun thai-pre-write-conversion (from to)
+ (let ((old-buf (current-buffer))
+ (work-buf (get-buffer-create " *thai-work*")))
+ (set-buffer work-buf)
+ (erase-buffer)
+ (insert-buffer-substring old-buf from to)
+ (decompose-region (point-min) (point-max))))
+
+;;
+(provide 'language/thai-util)
+
+;;; Local Variables:
+;;; generated-autoload-file: "../loaddefs.el"
+;;; End:
+;;; thai-util.el ends here
+
--- /dev/null
+;;; thai.el --- Support for Thai
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: multilingual, Thai
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; For Thai, the character set TIS620 is supported.
+
+;;; Code:
+
+(make-coding-system
+ 'coding-system-tis620 2 ?T
+ "Coding-system used for ASCII(MSB=0) & TIS620(MSB=1)."
+ '((ascii t) (thai-tis620 t) nil nil
+ nil ascii-eol))
+(put 'coding-system-tis620 'post-read-conversion
+ 'thai-post-read-conversion)
+(put 'coding-system-tis620 'pre-write-conversion
+ 'thai-pre-write-conversion)
+
+(register-input-method
+ "Thai" '("quail-thai" quail-use-package "quail/thai"))
+
+(defun setup-thai-environment ()
+ (setq coding-category-iso-8-1 'coding-system-tis620)
+
+ (set-coding-priority
+ '(coding-category-iso-7
+ coding-category-iso-8-1))
+
+ (setq-default buffer-file-coding-system 'coding-system-tis620)
+
+ (setq default-input-method '("Thai" . "quail-thai"))
+ )
+
+(set-language-info-alist
+ "Thai" '((tutorial . "TUTORIAL.th")
+ (setup-function . setup-thai-environment)
+ (charset . (thai-tis620))
+ (coding-systemm . (coding-system-tis620))
+ (documentation . t)
+ (sample-text . "Thai (\e,T@RIRd7B\e(B) \e,TJ\e0GQ\e1J\e04U\e1$\e0CQ\e1:\e(B, \e,TJ\e0GQ\e1J\e04U\e1\e0$h\e1P\e(B")))
+
+;;; thai.el ends here
--- /dev/null
+;; viet-util.el -- utilities for Vietnamese
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: mule, multilingual, Vietnamese
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; Vietnamese uses ASCII characters and additional 134 unique
+;; characters (these are Latin alphabets with various diacritical and
+;; tone marks). As far as I know, Vietnamese now has 4 different ways
+;; for representing these characters: VISCII, VSCII, VIQR, and
+;; Unicode. VISCII and VSCII are simple 1-byte code which assigns 134
+;; unique characters in control-code area (0x00..0x1F) and right half
+;; area (0x80..0xFF). VIQR is a menmonic encoding specification
+;; representing diacritical marks by following ASCII characters.
+
+;;; Code:
+
+;; VIQR is a menmonic encoding specification for Vietnamese.
+;; It represents diacritical marks by ASCII characters as follows:
+;; ------------+----------+--------
+;; mark | mnemonic | example
+;; ------------+----------+---------
+;; breve | ( | a( -> \e,1e\e(B
+;; circumflex | ^ | a^ -> \e,1b\e(B
+;; horn | + | o+ -> \e,1=\e(B
+;; ------------+----------+---------
+;; acute | ' | a' -> \e,1a\e(B
+;; grave | ` | a` -> \e,1`\e(B
+;; hook above | ? | a? -> \e,1d\e(B
+;; tilde | ~ | a~ -> \e,1c\e(B
+;; dot below | . | a. -> \e,1U\e(B
+;; ------------+----------+---------
+;; d bar | dd | dd -> \e,1p\e(B
+;; ------------+----------+---------
+
+(defvar viet-viqr-alist
+ '(;; lowercase
+ (?\e,1!\e(B . "a('") ; 161
+ (?\e,1"\e(B . "a(`") ; 162
+ (?\e,1#\e(B . "a(.") ; 163
+ (?\e,1$\e(B . "a^'") ; 164
+ (?\e,1%\e(B . "a^`") ; 165
+ (?\e,1&\e(B . "a^?") ; 166
+ (?\e,1'\e(B . "a^.") ; 167
+ (?\e,1(\e(B . "e~") ; 168
+ (?\e,1)\e(B . "e.") ; 169
+ (?\e,1*\e(B . "e^'") ; 170
+ (?\e,1+\e(B . "e^`") ; 171
+ (?\e,1,\e(B . "e^?") ; 172
+ (?\e,1-\e(B . "e^~") ; 173
+ (?\e,1.\e(B . "e^.") ; 174
+ (?\e,1/\e(B . "o^'") ; 175
+ (?\e,10\e(B . "o^`") ; 176
+ (?\e,11\e(B . "o^?") ; 177
+ (?\e,12\e(B . "o^~") ; 178
+ (?\e,15\e(B . "o^.") ; 181
+ (?\e,16\e(B . "o+`") ; 182
+ (?\e,17\e(B . "o+?") ; 183
+ (?\e,18\e(B . "i.") ; 184
+ (?\e,1=\e(B . "o+") ; 189
+ (?\e,1>\e(B . "o+'") ; 190
+ (?\e,1F\e(B . "a(?") ; 198
+ (?\e,1G\e(B . "a(~") ; 199
+ (?\e,1O\e(B . "y`") ; 207
+ (?\e,1Q\e(B . "u+'") ; 209
+ (?\e,1U\e(B . "a.") ; 213
+ (?\e,1V\e(B . "y?") ; 214
+ (?\e,1W\e(B . "u+`") ; 215
+ (?\e,1X\e(B . "u+?") ; 216
+ (?\e,1[\e(B . "y~") ; 219
+ (?\e,1\\e(B . "y.") ; 220
+ (?\e,1^\e(B . "o+~") ; 222
+ (?\e,1_\e(B . "u+") ; 223
+ (?\e,1`\e(B . "a`") ; 224
+ (?\e,1a\e(B . "a'") ; 225
+ (?\e,1b\e(B . "a^") ; 226
+ (?\e,1c\e(B . "a~") ; 227
+ (?\e,1d\e(B . "a?") ; 228
+ (?\e,1e\e(B . "a(") ; 229
+ (?\e,1f\e(B . "u+~") ; 230
+ (?\e,1g\e(B . "a^~") ; 231
+ (?\e,1h\e(B . "e`") ; 232
+ (?\e,1i\e(B . "e'") ; 233
+ (?\e,1j\e(B . "e^") ; 234
+ (?\e,1k\e(B . "e?") ; 235
+ (?\e,1l\e(B . "i`") ; 236
+ (?\e,1m\e(B . "i'") ; 237
+ (?\e,1n\e(B . "i~") ; 238
+ (?\e,1o\e(B . "i?") ; 239
+ (?\e,1p\e(B . "dd") ; 240
+ (?\e,1q\e(B . "u+.") ; 241
+ (?\e,1r\e(B . "o`") ; 242
+ (?\e,1s\e(B . "o'") ; 243
+ (?\e,1t\e(B . "o^") ; 244
+ (?\e,1u\e(B . "o~") ; 245
+ (?\e,1v\e(B . "o?") ; 246
+ (?\e,1w\e(B . "o.") ; 247
+ (?\e,1x\e(B . "u.") ; 248
+ (?\e,1y\e(B . "u`") ; 249
+ (?\e,1z\e(B . "u'") ; 250
+ (?\e,1{\e(B . "u~") ; 251
+ (?\e,1|\e(B . "u?") ; 252
+ (?\e,1}\e(B . "y'") ; 253
+ (?\e,1~\e(B . "o+.") ; 254
+
+ ;; upper case
+ (?\e,2!\e(B . "A('") ; 161
+ (?\e,2"\e(B . "A(`") ; 162
+ (?\e,2#\e(B . "A(.") ; 163
+ (?\e,2$\e(B . "A^'") ; 164
+ (?\e,2%\e(B . "A^`") ; 165
+ (?\e,2&\e(B . "A^?") ; 166
+ (?\e,2'\e(B . "A^.") ; 167
+ (?\e,2(\e(B . "E~") ; 168
+ (?\e,2)\e(B . "E.") ; 169
+ (?\e,2*\e(B . "E^'") ; 170
+ (?\e,2+\e(B . "E^`") ; 171
+ (?\e,2,\e(B . "E^?") ; 172
+ (?\e,2-\e(B . "E^~") ; 173
+ (?\e,2.\e(B . "E^.") ; 174
+ (?\e,2/\e(B . "O^'") ; 175
+ (?\e,20\e(B . "O^`") ; 176
+ (?\e,21\e(B . "O^?") ; 177
+ (?\e,22\e(B . "O^~") ; 178
+ (?\e,25\e(B . "O^.") ; 181
+ (?\e,26\e(B . "O+`") ; 182
+ (?\e,27\e(B . "O+?") ; 183
+ (?\e,28\e(B . "I.") ; 184
+ (?\e,2=\e(B . "O+") ; 189
+ (?\e,2>\e(B . "O+'") ; 190
+ (?\e,2F\e(B . "A(?") ; 198
+ (?\e,2G\e(B . "A(~") ; 199
+ (?\e,2O\e(B . "Y`") ; 207
+ (?\e,2Q\e(B . "U+'") ; 209
+ (?\e,2U\e(B . "A.") ; 213
+ (?\e,2V\e(B . "Y?") ; 214
+ (?\e,2W\e(B . "U+`") ; 215
+ (?\e,2X\e(B . "U+?") ; 216
+ (?\e,2[\e(B . "Y~") ; 219
+ (?\e,2\\e(B . "Y.") ; 220
+ (?\e,2^\e(B . "O+~") ; 222
+ (?\e,2_\e(B . "U+") ; 223
+ (?\e,2`\e(B . "A`") ; 224
+ (?\e,2a\e(B . "A'") ; 225
+ (?\e,2b\e(B . "A^") ; 226
+ (?\e,2c\e(B . "A~") ; 227
+ (?\e,2d\e(B . "A?") ; 228
+ (?\e,2e\e(B . "A(") ; 229
+ (?\e,2f\e(B . "U+~") ; 230
+ (?\e,2g\e(B . "A^~") ; 231
+ (?\e,2h\e(B . "E`") ; 232
+ (?\e,2i\e(B . "E'") ; 233
+ (?\e,2j\e(B . "E^") ; 234
+ (?\e,2k\e(B . "E?") ; 235
+ (?\e,2l\e(B . "I`") ; 236
+ (?\e,2m\e(B . "I'") ; 237
+ (?\e,2n\e(B . "I~") ; 238
+ (?\e,2o\e(B . "I?") ; 239
+ (?\e,2p\e(B . "DD") ; 240
+ (?\e,2p\e(B . "dD") ; 240
+ (?\e,2p\e(B . "Dd") ; 240
+ (?\e,2q\e(B . "U+.") ; 241
+ (?\e,2r\e(B . "O`") ; 242
+ (?\e,2s\e(B . "O'") ; 243
+ (?\e,2t\e(B . "O^") ; 244
+ (?\e,2u\e(B . "O~") ; 245
+ (?\e,2v\e(B . "O?") ; 246
+ (?\e,2w\e(B . "O.") ; 247
+ (?\e,2x\e(B . "U.") ; 248
+ (?\e,2y\e(B . "U`") ; 249
+ (?\e,2z\e(B . "U'") ; 250
+ (?\e,2{\e(B . "U~") ; 251
+ (?\e,2|\e(B . "U?") ; 252
+ (?\e,2}\e(B . "Y'") ; 253
+ (?\e,2~\e(B . "O+.") ; 254
+
+ ;; escape from composition
+ (?\( . "\\(") ; breve (left parenthesis)
+ (?^ . "\\^") ; circumflex (caret)
+ (?+ . "\\+") ; horn (plus sign)
+ (?' . "\\'") ; acute (apostrophe)
+ (?` . "\\`") ; grave (backquote)
+ (?? . "\\?") ; hook above (question mark)
+ (?~ . "\\~") ; tilde (tilde)
+ (?. . "\\.") ; dot below (period)
+ (?d . "\\d") ; d-bar (d)
+ (?\\ . "\\\\") ; literal backslash
+ )
+ "Alist of Vietnamese characters vs corresponding `VIQR' string.")
+
+;; Regular expression matching single Vietnamese character represented
+;; by VIQR.
+(defconst viqr-regexp
+ "[aeiouyAEIOUY]\\([(^+]?['`?~.]\\|[(^+]\\)\\|[Dd][Dd]")
+
+;;;###autoload
+(defun viet-decode-viqr-region (from to)
+ "Convert `VIQR' mnemonics of the current region to Vietnamese characaters.
+When called from a program, expects two arguments,
+positions (integers or markers) specifying the stretch of the region."
+ (interactive "r")
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (while (re-search-forward viqr-regexp nil t)
+ (let* ((viqr (buffer-substring (match-beginning 0) (match-end 0)))
+ (ch (car (rassoc viet-viqr-alist viqr))))
+ (if ch
+ (progn
+ (delete-region (match-beginning 0) (match-end 0))
+ (insert ch)))))))
+
+;;;###autoload
+(defun viet-decode-viqr-buffer ()
+ "Convert `VIQR' mnemonics of the current buffer to Vietnamese characaters."
+ (interactive)
+ (viet-decode-viqr-region (point-min) (point-max)))
+
+;;;###autoload
+(defun viet-encode-viqr-region (from to)
+ "Convert Vietnamese characaters of the current region to `VIQR' mnemonics.
+When called from a program, expects two arguments,
+positions (integers or markers) specifying the stretch of the region."
+ (interactive "r")
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (while (re-search-forward "\\cv" nil t)
+ (let* ((ch (preceding-char))
+ (viqr (cdr (assoc viet-viqr-alist ch))))
+ (if viqr
+ (progn
+ (delete-char -1)
+ (insert viqr)))))))
+
+;;;###autoload
+(defun viet-encode-viqr-buffer ()
+ "Convert Vietnamese characaters of the current buffer to `VIQR' mnemonics."
+ (interactive)
+ (viet-encode-viqr-region (point-min) (point-max)))
+
+;;;
+(provide 'language/viet-util)
+
+;;; Local Variables:
+;;; generated-autoload-file: "../loaddefs.el"
+;;; End:
+;;; viet-util.el ends here
--- /dev/null
+;;; vietnamese.el --- Support for Vietnamese
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+;; Keywords: multilingual, Vietnamese
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; For Vietnames, the character sets VISCII and VSCII are supported.
+
+;;; Code:
+
+(eval-when-compile
+
+(defvar viet-viscii-decode-table
+ [;; VISCII is a full 8-bit code.
+ 0 1 ?\e,2F\e(B 3 4 ?\e,2G\e(B ?\e,2g\e(B 7 8 9 10 11 12 13 14 15
+ 16 17 18 19 ?\e,2V\e(B 21 22 23 24 ?\e,2[\e(B 26 27 28 29 ?\e,2\\e(B 31
+ 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47
+ 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63
+ 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79
+ 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
+ 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111
+ 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
+ ?\e,2U\e(B ?\e,2!\e(B ?\e,2"\e(B ?\e,2#\e(B ?\e,2$\e(B ?\e,2%\e(B ?\e,2&\e(B ?\e,2'\e(B ?\e,2(\e(B ?\e,2)\e(B ?\e,2*\e(B ?\e,2+\e(B ?\e,2,\e(B ?\e,2-\e(B ?\e,2.\e(B ?\e,2/\e(B
+ ?\e,20\e(B ?\e,21\e(B ?\e,22\e(B ?\e,25\e(B ?\e,2~\e(B ?\e,2>\e(B ?\e,26\e(B ?\e,27\e(B ?\e,28\e(B ?\e,2v\e(B ?\e,2w\e(B ?\e,2o\e(B ?\e,2|\e(B ?\e,2{\e(B ?\e,2x\e(B ?\e,2O\e(B
+ ?\e,2u\e(B ?\e,1!\e(B ?\e,1"\e(B ?\e,1#\e(B ?\e,1$\e(B ?\e,1%\e(B ?\e,1&\e(B ?\e,1'\e(B ?\e,1(\e(B ?\e,1)\e(B ?\e,1*\e(B ?\e,1+\e(B ?\e,1,\e(B ?\e,1-\e(B ?\e,1.\e(B ?\e,1/\e(B
+ ?\e,10\e(B ?\e,11\e(B ?\e,12\e(B ?\e,2^\e(B ?\e,2=\e(B ?\e,15\e(B ?\e,16\e(B ?\e,17\e(B ?\e,18\e(B ?\e,2q\e(B ?\e,2Q\e(B ?\e,2W\e(B ?\e,2X\e(B ?\e,1=\e(B ?\e,1>\e(B ?\e,2_\e(B
+ ?\e,2`\e(B ?\e,2a\e(B ?\e,2b\e(B ?\e,2c\e(B ?\e,2d\e(B ?\e,2e\e(B ?\e,1F\e(B ?\e,1G\e(B ?\e,2h\e(B ?\e,2i\e(B ?\e,2j\e(B ?\e,2k\e(B ?\e,2l\e(B ?\e,2m\e(B ?\e,2n\e(B ?\e,1O\e(B
+ ?\e,2p\e(B ?\e,1Q\e(B ?\e,2r\e(B ?\e,2s\e(B ?\e,2t\e(B ?\e,1U\e(B ?\e,1V\e(B ?\e,1W\e(B ?\e,1X\e(B ?\e,2y\e(B ?\e,2z\e(B ?\e,1[\e(B ?\e,1\\e(B ?\e,2}\e(B ?\e,1^\e(B ?\e,1_\e(B
+ ?\e,1`\e(B ?\e,1a\e(B ?\e,1b\e(B ?\e,1c\e(B ?\e,1d\e(B ?\e,1e\e(B ?\e,1f\e(B ?\e,1g\e(B ?\e,1h\e(B ?\e,1i\e(B ?\e,1j\e(B ?\e,1k\e(B ?\e,1l\e(B ?\e,1m\e(B ?\e,1n\e(B ?\e,1o\e(B
+ ?\e,1p\e(B ?\e,1q\e(B ?\e,1r\e(B ?\e,1s\e(B ?\e,1t\e(B ?\e,1u\e(B ?\e,1v\e(B ?\e,1w\e(B ?\e,1x\e(B ?\e,1y\e(B ?\e,1z\e(B ?\e,1{\e(B ?\e,1|\e(B ?\e,1}\e(B ?\e,1~\e(B ?\e,2f\e(B ]
+ "Vietnamese VISCII encoding table.")
+
+(defvar viet-viscii-encode-table
+ (let ((table-lower (make-vector 128 0))
+ (table-upper (make-vector 128 0))
+ (i 0)
+ char-component)
+ (while (< i 256)
+ (setq char-component (split-char (aref viet-viscii-decode-table i)))
+ (cond ((eq (car char-component) 'vietnamese-viscii-lower)
+ (aset table-lower (nth 1 char-component) i))
+ ((eq (car char-component) 'vietnamese-viscii-upper)
+ (aset table-upper (nth 1 char-component) i)))
+ (setq i (1+ i)))
+ (cons table-lower table-upper))
+ "Vietnamese VISCII decoding table.
+Cons of tables for decoding lower-case chars and upper-case characterss.
+Both tables are indexed by the position code of Vietnamese characters.")
+
+(defvar viet-vscii-decode-table
+ [;; VSCII is a full 8-bit code.
+ 0 ?\e,2z\e(B ?\e,2x\e(B 3 ?\e,2W\e(B ?\e,2X\e(B ?\e,2f\e(B 7 8 9 10 11 12 13 14 15
+ 16 ?\e,2Q\e(B ?\e,2_\e(B ?\e,2O\e(B ?\e,2V\e(B ?\e,2[\e(B ?\e,2}\e(B ?\e,2\\e(B 24 25 26 27 28 29 30 31
+ 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47
+ 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63
+ 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79
+ 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
+ 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111
+ 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
+ ?\e,2`\e(B ?\e,2d\e(B ?\e,2c\e(B ?\e,2a\e(B ?\e,2U\e(B ?\e,2#\e(B ?\e,2'\e(B ?\e,2h\e(B ?\e,2k\e(B ?\e,2(\e(B ?\e,2i\e(B ?\e,2)\e(B ?\e,2.\e(B ?\e,2l\e(B ?\e,2o\e(B ?\e,2n\e(B
+ ?\e,2m\e(B ?\e,28\e(B ?\e,2r\e(B ?\e,2v\e(B ?\e,2u\e(B ?\e,2s\e(B ?\e,2w\e(B ?\e,25\e(B ?\e,26\e(B ?\e,27\e(B ?\e,2^\e(B ?\e,2>\e(B ?\e,2~\e(B ?\e,2y\e(B ?\e,2|\e(B ?\e,2{\e(B
+ 160 ?\e,2e\e(B ?\e,2b\e(B ?\e,2j\e(B ?\e,2t\e(B ?\e,2=\e(B ?\e,2_\e(B ?\e,2p\e(B ?\e,1e\e(B ?\e,1b\e(B ?\e,1j\e(B ?\e,1t\e(B ?\e,1>\e(B ?\e,1y\e(B ?\e,1p\e(B ?\e,2"\e(B
+ 192 193 194 195 196 ?\e,1`\e(B ?\e,1d\e(B ?\e,1c\e(B ?\e,1a\e(B ?\e,1U\e(B ?\e,2F\e(B ?\e,1"\e(B ?\e,1F\e(B ?\e,1G\e(B ?\e,1!\e(B ?\e,2G\e(B
+ ?\e,2!\e(B ?\e,2%\e(B ?\e,2&\e(B ?\e,2g\e(B ?\e,2%\e(B ?\e,2+\e(B ?\e,1#\e(B ?\e,1%\e(B ?\e,1&\e(B ?\e,1g\e(B ?\e,1$\e(B ?\e,1'\e(B ?\e,1h\e(B ?\e,2,\e(B ?\e,1k\e(B ?\e,1(\e(B
+ ?\e,1i\e(B ?\e,1)\e(B ?\e,1+\e(B ?\e,1,\e(B ?\e,1-\e(B ?\e,1*\e(B ?\e,1.\e(B ?\e,1l\e(B ?\e,1o\e(B ?\e,2-\e(B ?\e,2*\e(B ?\e,20\e(B ?\e,1n\e(B ?\e,1m\e(B ?\e,18\e(B ?\e,1r\e(B
+ ?\e,21\e(B ?\e,1v\e(B ?\e,1u\e(B ?\e,1s\e(B ?\e,1w\e(B ?\e,10\e(B ?\e,11\e(B ?\e,12\e(B ?\e,1/\e(B ?\e,15\e(B ?\e,16\e(B ?\e,17\e(B ?\e,1^\e(B ?\e,1>\e(B ?\e,1~\e(B ?\e,1y\e(B
+ ?\e,22\e(B ?\e,1|\e(B ?\e,1{\e(B ?\e,1z\e(B ?\e,1x\e(B ?\e,1W\e(B ?\e,1X\e(B ?\e,1f\e(B ?\e,1Q\e(B ?\e,1q\e(B ?\e,1O\e(B ?\e,1V\e(B ?\e,1[\e(B ?\e,1}\e(B ?\e,1\\e(B ?\e,2/\e(B]
+ "Vietnamese VSCII code table.")
+
+(defvar viet-vscii-encode-table
+ (let ((table-lower (make-vector 128 0))
+ (table-upper (make-vector 128 0))
+ (i 0)
+ char-component)
+ (while (< i 256)
+ (setq char-component (split-char (aref viet-vscii-decode-table i)))
+ (cond ((eq (car char-component) 'vietnamese-viscii-lower)
+ (aset table-lower (nth 1 char-component) i))
+ ((eq (car char-component) 'vietnamese-viscii-upper)
+ (aset table-upper (nth 1 char-component) i)))
+ (setq i (1+ i)))
+ (cons table-lower table-upper))
+ "Vietnamese VSCII decoding table.
+Cons of tables for decoding lower-case chars and upper-case characterss.
+Both tables are indexed by the position code of Vietnamese characters.")
+
+)
+
+(define-ccl-program ccl-decode-viscii
+ `(3
+ ((read r0)
+ (loop
+ (write-read-repeat r0 ,viet-viscii-decode-table))
+ ))
+ "CCL program to decode VISCII 1.1")
+
+;; Multibyte form of a Vietnamese character is as follows (3-byte):
+;; LEADING-CODE-PRIVATE-11 LEADING-CODE-EXTENDED-11 POSITION-CODE
+;; where LEADING-CODE-EXTENDED-11 for Vietnamese is
+;; `vietnamese-viscii-lower' or `vietnamese-viscii-upper'.
+
+(define-ccl-program ccl-encode-viscii
+ `(1
+ ((read r0)
+ (loop
+ (if (r0 < 128)
+ ;; ASCII
+ (write-read-repeat r0)
+ ;; not ASCII
+ (if (r0 != ,leading-code-private-11)
+ ;; not Vietnamese
+ (write-read-repeat r0)
+ ((read-if (r0 == ,(charset-id 'vietnamese-viscii-lower))
+ (;; Vietnamese lower
+ (read r0)
+ (r0 -= 128)
+ (write-read-repeat r0 ,(car viet-viscii-encode-table)))
+ (if (r0 == ,(charset-id 'vietnamese-viscii-upper))
+ (;; Vietnamese upper
+ (read r0)
+ (r0 -= 128)
+ (write-read-repeat r0 ,(cdr viet-viscii-encode-table)))
+ ;; not Vietnamese
+ (write-read-repeat r0)))))))))
+ "CCL program to encode VISCII 1.1")
+
+(define-ccl-program ccl-encode-viscii-font
+ `(0
+ ;; In: R0:vietnamese-viscii-lower/vietnamese-viscii-upper
+ ;; R1:position code
+ ;; Out: R1:font code point
+ (if (r0 == ,(charset-id 'vietnamese-viscii-lower))
+ (r1 = r1 ,(car viet-viscii-encode-table))
+ (r1 = r1 ,(cdr viet-viscii-encode-table)))
+ )
+ "CCL program to encode Vietnamese chars to VISCII 1.1 font")
+
+(define-ccl-program ccl-decode-vscii
+ `(3
+ ((read r0)
+ (loop
+ (write-read-repeat r0 ,viet-vscii-decode-table))
+ ))
+ "CCL program to decode VSCII-1.")
+
+(define-ccl-program ccl-encode-vscii
+ `(1
+ ((read r0)
+ (loop
+ (if (r0 < 128)
+ ;; ASCII
+ (write-read-repeat r0)
+ ;; not ASCII
+ (if (r0 != ,leading-code-private-11)
+ ;; not Vietnamese
+ (write-read-repeat r0)
+ (read-if (r0 == ,(charset-id 'vietnamese-viscii-lower))
+ (;; Vietnamese lower
+ (read r0)
+ (r0 -= 128)
+ (write-read-repeat r0 ,(car viet-vscii-encode-table)))
+ (if (r0 == ,(charset-id 'vietnamese-viscii-upper))
+ (;; Vietnamese upper
+ (read r0)
+ (r0 -= 128)
+ (write-read-repeat r0 ,(cdr viet-viscii-encode-table)))
+ ;; not Vietnamese
+ (write-read-repeat r0))))))))
+ "CCL program to encode VSCII-1.")
+
+(define-ccl-program ccl-encode-vscii-font
+ `(0
+ ;; In: R0:vietnamese-viscii-lower/vietnamese-viscii-upper
+ ;; R1:position code
+ ;; Out: R1:font code point
+ (if (r0 == ,(charset-id 'vietnamese-viscii-lower))
+ (r1 = r1 ,(car viet-vscii-encode-table))
+ (r1 = r1 ,(cdr viet-vscii-encode-table)))
+ )
+ "CCL program to encode Vietnamese chars to VSCII-1 font.")
+
+
+(make-coding-system
+ 'coding-system-viscii 4 ?V
+ "Coding-system used for VISCII 1.1."
+ (cons ccl-decode-viscii ccl-encode-viscii))
+
+(make-coding-system
+ 'coding-system-vscii 4 ?V
+ "Coding-system used for VSCII-1."
+ (cons ccl-decode-vscii ccl-encode-vscii))
+
+(make-coding-system
+ 'coding-system-viqr 0 ?v
+ "Codins-system used for VIQR."
+ nil)
+(put 'coding-system-viqr 'post-read-conversion 'viet-decode-viqr-region)
+(put 'coding-system-viqr 'pre-write-conversion 'viet-encode-viqr-region)
+
+(setq font-ccl-encoder-alist
+ (cons (cons "viscii" ccl-encode-viscii-font) font-ccl-encoder-alist))
+
+(setq font-ccl-encoder-alist
+ (cons (cons "vscii" ccl-encode-vscii-font) font-ccl-encoder-alist))
+
+(register-input-method
+ "Vietnamese" '("quail-viqr" quail-use-package "quail/viqr"))
+
+(defun setup-viet-environment ()
+ ;; for VISCII users
+ (setq coding-category-binary 'coding-system-viscii)
+
+ ;; for VSCII users
+ ;; (setq coding-category-binary 'coding-system-vscii)
+
+ (set-coding-priority
+ '(coding-category-iso-7
+ coding-category-binary))
+
+ (setq-default buffer-file-coding-system 'coding-system-viscii)
+
+ (setq default-input-method '("Vietnamese" . "quail-viqr"))
+ )
+
+(set-language-info-alist
+ "Vietnamese" '((setup-function . setup-viet-environment)
+ (charset . (vietnamese-viscii-lower
+ vietnamese-viscii-upper))
+ (coding-system . (coding-system-viscii
+ coding-system-vscii
+ coding-system-viqr))
+ (documentation . t)
+ (sample-text . "Vietnamese (Ti\e,1*\e(Bng Vi\e,1.\e(Bt) Ch\e,1`\e(Bo b\e,1U\e(Bn")))
+
+;;; vietnamese.el ends here
--- /dev/null
+/* GNU Emacs routines to deal with category tables.
+ Ver.1.0
+
+ Copyright (C) 1995 Free Software Foundation, Inc.
+ Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+/* Here we handle three objects: category, category set, and category
+ table. Read comments in the file category.h to understand them. */
+
+#include <config.h>
+#include <ctype.h>
+#include "lisp.h"
+#include "buffer.h"
+#include "charset.h"
+#include "category.h"
+
+/* The version number of the latest category table. Each category
+ table has a unique version number. It is assigned a new number
+ also when it is modified. When a regular expression is compiled
+ into the struct re_pattern_buffer, the version number of the
+ category table (of the current buffer) at that moment is also
+ embedded in the structure.
+
+ For the moment, we are not using this feature. */
+static int category_table_version;
+
+Lisp_Object Qcategory_table, Qcategoryp, Qcategorysetp, Qcategory_table_p;
+
+/* Variables to determine word boundary. */
+Lisp_Object Vword_combining_categories, Vword_separating_categories;
+
+/* Temporary internal variable used in macro CHAR_HAS_CATEGORY. */
+Lisp_Object _temp_category_set;
+
+\f
+/* Category set staff. */
+
+DEFUN ("make-category-set", Fmake_category_set, Smake_category_set, 1, 1, 0,
+ "Return a newly created category-set which contains CATEGORIES.\n\
+CATEGORIES is a string of category mnemonics.")
+ (categories)
+ Lisp_Object categories;
+{
+ Lisp_Object val;
+ int len;
+
+ CHECK_STRING (categories, 0);
+ val = MAKE_CATEGORY_SET;
+
+ len = XSTRING (categories)->size;
+ while (--len >= 0)
+ {
+ Lisp_Object category = make_number (XSTRING (categories)->data[len]);
+
+ CHECK_CATEGORY (category, 0);
+ SET_CATEGORY_SET (val, category, Qt);
+ }
+ return val;
+}
+
+\f
+/* Category staff. */
+
+Lisp_Object check_category_table ();
+
+DEFUN ("define-category", Fdefine_category, Sdefine_category, 2, 3, 0,
+ "Define CHAR as a category which is described by DOCSTRING.\n\
+CHAR should be a visible letter of ` ' thru `~'.\n\
+DOCSTRING is a documentation string of the category.\n\
+The category is defined only in category table TABLE, which defaults to\n\
+ the current buffer's category table.")
+ (category, docstring, table)
+ Lisp_Object category, docstring, table;
+{
+ CHECK_CATEGORY (category, 0);
+ CHECK_STRING (docstring, 1);
+ table = check_category_table (table);
+
+ if (!NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
+ error ("Category `%c' is already defined", XFASTINT (category));
+ CATEGORY_DOCSTRING (table, XFASTINT (category)) = docstring;
+
+ return Qnil;
+}
+
+DEFUN ("category-docstring", Fcategory_docstring, Scategory_docstring, 1, 2, 0,
+ "Return a documentation string of CATEGORY.\n\
+Optional second arg specifies CATEGORY-TABLE,\n\
+ which defaults to the current buffer's category table.")
+ (category, table)
+ Lisp_Object category, table;
+{
+ Lisp_Object doc;
+
+ CHECK_CATEGORY (category, 0);
+ table = check_category_table (table);
+
+ return CATEGORY_DOCSTRING (table, XFASTINT (category));
+}
+
+DEFUN ("get-unused-category", Fget_unused_category, Sget_unused_category,
+ 0, 1, 0,
+ "Return a category which is not yet defined.\n\
+If total number of categories has reached the limit (95), return nil.\n\
+Optional argument specifies CATEGORY-TABLE,\n\
+ which defaults to the current buffer's category table.")
+ (table)
+ Lisp_Object table;
+{
+ int i;
+ Lisp_Object docstring_vector;
+
+ table = check_category_table (table);
+
+ for (i = ' '; i <= '~'; i++)
+ if (NILP (CATEGORY_DOCSTRING (table, i)))
+ return make_number (i);
+
+ return Qnil;
+}
+
+\f
+/* Category-table staff. */
+
+DEFUN ("category-table-p", Fcategory_table_p, Scategory_table_p, 1, 1, 0,
+ "Return t if ARG is a category table.")
+ (arg)
+ Lisp_Object arg;
+{
+ if (CHAR_TABLE_P (arg)
+ && EQ (XCHAR_TABLE (arg)->purpose, Qcategory_table)
+ && CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (arg)) == 2)
+ return Qt;
+ return Qnil;
+}
+
+/* If TABLE is nil, return the current category table. If TABLE is
+ not nil, check the validity of TABLE as a category table. If
+ valid, return TABLE itself, but if not valid, signal an error of
+ wrong-type-argument. */
+
+Lisp_Object
+check_category_table (table)
+ Lisp_Object table;
+{
+ register Lisp_Object tem;
+ if (NILP (table))
+ return current_buffer->category_table;
+ while (tem = Fcategory_table_p (table), NILP (tem))
+ table = wrong_type_argument (Qcategory_table_p, table);
+ return table;
+}
+
+DEFUN ("category-table", Fcategory_table, Scategory_table, 0, 0, 0,
+ "Return the current category table.\n\
+This is the one specified by the current buffer.")
+ ()
+{
+ return current_buffer->category_table;
+}
+
+DEFUN ("standard-category-table", Fstandard_category_table,
+ Sstandard_category_table, 0, 0, 0,
+ "Return the standard category table.\n\
+This is the one used for new buffers.")
+ ()
+{
+ return Vstandard_category_table;
+}
+
+/* Return a copy of category table TABLE. We can't simply use the
+ function copy-sequence because no contents should be shared between
+ the original and the copy.
+
+ If TOP is 1, we at first copy the tree structure of the table. */
+
+Lisp_Object
+copy_category_table (table, top)
+ Lisp_Object table;
+{
+ int i;
+
+ if (top)
+ table = Fcopy_sequence (table);
+ else if (!NILP (XCHAR_TABLE (table)->defalt))
+ XCHAR_TABLE (table)->defalt
+ = Fcopy_sequence (XCHAR_TABLE (table)->defalt);
+
+ for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
+ {
+ Lisp_Object idx = make_number (i);
+ Lisp_Object val = Faref (table, idx);
+
+ if (NILP (val)) /* Do nothing because we can share nil. */
+ ;
+ else if (CATEGORY_SET_P (val))
+ Faset (table, idx, Fcopy_sequence (val));
+ else if (CHAR_TABLE_P (val))
+ Faset (table, idx, copy_category_table (val, 0));
+ else /* Invalid contents. */
+ Faset (table, idx, Qnil);
+ }
+
+ return table;
+}
+
+DEFUN ("copy-category-table", Fcopy_category_table, Scopy_category_table,
+ 0, 1, 0,
+ "Construct a new category table and return it.\n\
+It is a copy of the TABLE, which defaults to the standard category table.")
+ (table)
+ Lisp_Object table;
+{
+ if (!NILP (table))
+ check_category_table (table);
+ else
+ table = Vstandard_category_table;
+
+ return copy_category_table (table, 1);
+}
+
+DEFUN ("set-category-table", Fset_category_table, Sset_category_table, 1, 1, 0,
+ "Select a new category table for the current buffer.\n\
+One argument, a category table.")
+ (table)
+ Lisp_Object table;
+{
+ table = check_category_table (table);
+ current_buffer->category_table = table;
+ /* Indicate that this buffer now has a specified category table. */
+ current_buffer->local_var_flags
+ |= XFASTINT (buffer_local_flags.category_table);
+ return table;
+}
+
+\f
+DEFUN ("char-category-set", Fchar_category_set, Schar_category_set, 1, 1, 0,
+ "Return a category set of CHAR.")
+ (ch)
+ Lisp_Object ch;
+{
+ Lisp_Object val;
+ int charset;
+ unsigned char c1, c2;
+
+ CHECK_NUMBER (ch, 0);
+ return CATEGORY_SET (XFASTINT (ch));
+}
+
+DEFUN ("category-set-mnemonics", Fcategory_set_mnemonics,
+ Scategory_set_mnemonics, 1, 1, 0,
+ "Return a string of mnemonics of all categories in CATEGORY-SET.")
+ (category_set)
+ Lisp_Object category_set;
+{
+ int i, j;
+ char str[96];
+
+ CHECK_CATEGORY_SET (category_set, 0);
+
+ j = 0;
+ for (i = 32; i < 127; i++)
+ if (CATEGORY_MEMBER (i, category_set))
+ str[j++] = i;
+ str[j] = '\0';
+
+ return build_string (str);
+}
+
+/* Modify all category sets stored under category table TABLE so that
+ they contain (SET_VALUE is t) or don't contain (SET_VALUE is nil)
+ CATEGORY. */
+
+void
+modify_lower_category_set (table, category, set_value)
+ Lisp_Object table, category, set_value;
+{
+ Lisp_Object val;
+ int i;
+
+ if (NILP (XCHAR_TABLE (table)->defalt))
+ {
+ val = MAKE_CATEGORY_SET;
+ SET_CATEGORY_SET (val, category, set_value);
+ XCHAR_TABLE (table)->defalt = val;
+ }
+
+ for (i = 32; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
+ {
+ val = XCHAR_TABLE (table)->contents[i];
+
+ if (CATEGORY_SET_P (val))
+ SET_CATEGORY_SET (val, category, set_value);
+ else if (CHAR_TABLE_P (val))
+ modify_lower_category_set (val, category, set_value);
+ }
+}
+
+void
+set_category_set (category_set, category, val)
+ Lisp_Object category_set, category, val;
+{
+ do {
+ int idx = XINT (category) / 8;
+ unsigned char bits = 1 << (XINT (category) % 8);
+
+ if (NILP (val))
+ XCATEGORY_SET (category_set)->data[idx] &= ~bits;
+ else
+ XCATEGORY_SET (category_set)->data[idx] |= bits;
+ } while (0);
+}
+
+DEFUN ("modify-category-entry", Fmodify_category_entry,
+ Smodify_category_entry, 2, 4, 0,
+ "Modify the category set of CHAR by adding CATEGORY to it.\n\
+The category is changed only for table TABLE, which defaults to\n\
+ the current buffer's category table.\n\
+If optional forth argument RESET is non NIL,\n\
+ CATEGORY is deleted from the category set instead of being added.")
+ (ch, category, table, reset)
+ Lisp_Object ch, category, table, reset;
+{
+ int c, charset, c1, c2;
+ Lisp_Object set_value; /* Actual value to be set in category sets. */
+ Lisp_Object val, category_set;
+
+ CHECK_NUMBER (ch, 0);
+ c = XINT (ch);
+ CHECK_CATEGORY (category, 1);
+ table = check_category_table (table);
+
+ if (NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
+ error ("Undefined category: %c", XFASTINT (category));
+
+ set_value = NILP (reset) ? Qt : Qnil;
+
+ if (SINGLE_BYTE_CHAR_P (c))
+ {
+ val = XCHAR_TABLE (table)->contents[c];
+ if (!CATEGORY_SET_P (val))
+ XCHAR_TABLE (table)->contents[c] = (val = MAKE_CATEGORY_SET);
+ SET_CATEGORY_SET (val, category, set_value);
+ return Qnil;
+ }
+
+ if (COMPOSITE_CHAR_P (c))
+ c = cmpchar_component (c, 0);
+ SPLIT_NON_ASCII_CHAR (c, charset, c1, c2);
+
+ /* The top level table. */
+ val = XCHAR_TABLE (table)->contents[charset];
+ if (NILP (val))
+ {
+ category_set = MAKE_CATEGORY_SET;
+ XCHAR_TABLE (table)->contents[charset] = category_set;
+ }
+ else if (CATEGORY_SET_P (val))
+ category_set = val;
+
+ if (!c1)
+ {
+ /* Only a charset is specified. */
+ if (CHAR_TABLE_P (val))
+ /* All characters in CHARSET should be the same as for CATEGORY. */
+ modify_lower_category_set (val, category, set_value);
+ else
+ SET_CATEGORY_SET (category_set, category, set_value);
+ return Qnil;
+ }
+
+ /* The second level table. */
+ if (!CHAR_TABLE_P (val))
+ {
+ val = Fmake_char_table (Qnil, Qnil);
+ XCHAR_TABLE (table)->contents[charset] = val;
+ /* We must set default category set of CHARSET in `defalt' slot. */
+ XCHAR_TABLE (val)->defalt = category_set;
+ }
+ table = val;
+
+ val = XCHAR_TABLE (table)->contents[c1];
+ if (NILP (val))
+ {
+ category_set = Fcopy_sequence (XCHAR_TABLE (table)->defalt);
+ XCHAR_TABLE (table)->contents[c1] = category_set;
+ }
+ else if (CATEGORY_SET_P (val))
+ category_set = val;
+
+ if (!c2)
+ {
+ if (CHAR_TABLE_P (val))
+ /* All characters in C1 group of CHARSET should be the same as
+ for CATEGORY. */
+ modify_lower_category_set (val, category, set_value);
+ else
+ SET_CATEGORY_SET (category_set, category, set_value);
+ return Qnil;
+ }
+
+ /* The third (bottom) level table. */
+ if (!CHAR_TABLE_P (val))
+ {
+ val = Fmake_char_table (Qnil, Qnil);
+ XCHAR_TABLE (table)->contents[c1] = val;
+ /* We must set default category set of CHARSET and C1 in
+ `defalt' slot. */
+ XCHAR_TABLE (val)->defalt = category_set;
+ }
+ table = val;
+
+ val = XCHAR_TABLE (table)->contents[c2];
+ if (NILP (val))
+ {
+ category_set = Fcopy_sequence (XCHAR_TABLE (table)->defalt);
+ XCHAR_TABLE (table)->contents[c2] = category_set;
+ }
+ else if (CATEGORY_SET_P (val))
+ category_set = val;
+ else
+ /* This should never happen. */
+ error ("Invalid category table");
+
+ SET_CATEGORY_SET (category_set, category, set_value);
+
+ return Qnil;
+}
+\f
+/* Dump category table to buffer in human-readable format */
+
+static void
+describe_category (value)
+ Lisp_Object value;
+{
+ Lisp_Object mnemonics;
+
+ Findent_to (make_number (16), make_number (1));
+
+ if (NILP (value))
+ {
+ insert_string ("default\n");
+ return;
+ }
+
+ if (!CATEGORY_SET_P (value))
+ {
+ insert_string ("invalid\n");
+ return;
+ }
+
+ mnemonics = Fcategory_set_mnemonics (value);
+ insert_from_string (mnemonics, 0, XSTRING (mnemonics)->size, 0);
+ insert_string ("\n");
+ return;
+}
+
+static Lisp_Object
+describe_category_1 (vector)
+ Lisp_Object vector;
+{
+ struct buffer *old = current_buffer;
+ set_buffer_internal (XBUFFER (Vstandard_output));
+ describe_vector (vector, Qnil, describe_category, 0, Qnil, Qnil);
+ {
+ int i;
+ Lisp_Object docs = XCHAR_TABLE (vector)->extras[0];
+ Lisp_Object elt;
+
+ if (!VECTORP (docs) || XVECTOR (docs)->size != 95)
+ {
+ insert_string ("Invalid first extra slot in this char table\n");
+ return Qnil;
+ }
+
+ insert_string ("Meanings of mnemonice characters are:\n");
+ for (i = 0; i < 95; i++)
+ {
+ elt = XVECTOR (docs)->contents[i];
+ if (NILP (elt))
+ continue;
+
+ insert_char (i + 32);
+ insert (": ", 2);
+ insert_from_string (elt, 0, XSTRING (elt)->size, 0);
+ insert ("\n", 1);
+ }
+ }
+
+ while (! NILP (XCHAR_TABLE (vector)->parent))
+ {
+ vector = XCHAR_TABLE (vector)->parent;
+ insert_string ("\nThe parent category table is:");
+ describe_vector (vector, Qnil, describe_category, 0, Qnil, Qnil);
+ }
+
+ call0 (intern ("help-mode"));
+ set_buffer_internal (old);
+ return Qnil;
+}
+
+DEFUN ("describe-category", Fdescribe_category, Sdescribe_category, 0, 0, "",
+ "Describe the category specifications in the category table.\n\
+The descriptions are inserted in a buffer, which is then displayed.")
+ ()
+{
+ internal_with_output_to_temp_buffer
+ ("*Help*", describe_category_1, current_buffer->category_table);
+
+ return Qnil;
+}
+\f
+/* Return 1 if there is a word boundary between two word-constituent
+ characters C1 and C2 if they appear in this order, else return 0.
+ Use the macro WORD_BOUNDARY_P instead of calling this function
+ directly. */
+
+int
+word_boundary_p (c1, c2)
+ int c1, c2;
+{
+ Lisp_Object category_set1, category_set2;
+ Lisp_Object tail;
+ int default_result;
+
+ if (CHAR_CHARSET (c1) == CHAR_CHARSET (c2))
+ {
+ tail = Vword_separating_categories;
+ default_result = 0;
+ }
+ else
+ {
+ tail = Vword_combining_categories;
+ default_result = 1;
+ }
+
+ category_set1 = CATEGORY_SET (c1);
+ if (NILP (category_set1))
+ return default_result;
+ category_set2 = CATEGORY_SET (c2);
+ if (NILP (category_set2))
+ return default_result;
+
+ for (; CONSP (tail); tail = XCONS (tail)->cdr)
+ {
+ Lisp_Object elt = XCONS(tail)->car;
+
+ if (CONSP (elt)
+ && CATEGORYP (XCONS (elt)->car)
+ && CATEGORYP (XCONS (elt)->cdr)
+ && CATEGORY_MEMBER (XCONS (elt)->car, category_set1)
+ && CATEGORY_MEMBER (XCONS (elt)->cdr, category_set2))
+ return !default_result;
+ }
+ return default_result;
+}
+
+\f
+init_category_once ()
+{
+ /* This has to be done here, before we call Fmake_char_table. */
+ Qcategory_table = intern ("category-table");
+ staticpro (&Qcategory_table);
+
+ /* Intern this now in case it isn't already done.
+ Setting this variable twice is harmless.
+ But don't staticpro it here--that is done in alloc.c. */
+ Qchar_table_extra_slots = intern ("char-table-extra-slots");
+
+ /* Now we are ready to set up this property, so we can
+ create category tables. */
+ Fput (Qcategory_table, Qchar_table_extra_slots, make_number (2));
+
+ Vstandard_category_table = Fmake_char_table (Qcategory_table, Qnil);
+ /* Set a category set which contains nothing to the default. */
+ XCHAR_TABLE (Vstandard_category_table)->defalt = MAKE_CATEGORY_SET;
+ Fset_char_table_extra_slot (Vstandard_category_table, 0,
+ Fmake_vector (make_number (95), Qnil));
+}
+
+syms_of_category ()
+{
+ Qcategoryp = intern ("categoryp");
+ staticpro (&Qcategoryp);
+ Qcategorysetp = intern ("categorysetp");
+ staticpro (&Qcategorysetp);
+ Qcategory_table_p = intern ("category-table-p");
+ staticpro (&Qcategory_table_p);
+
+ DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories,
+ "List of pair (cons) of categories to determine word boundary.\n\
+\n\
+Emacs treats a sequence of word constituent characters as a single\n\
+word (i.e. finds no word boundary between them) iff they belongs to\n\
+the same charset. But, exceptions are allowed in the following cases.\n\
+\n\
+(1) The case that characters are in different charsets is controlled\n\
+by the variable `word-combining-categories'.\n\
+\n\
+Emacs finds no word boundary between characters of different charsets\n\
+if they have categories matching some element of this list.\n\
+\n\
+More precisely, if an element of this list is a cons of category CAT1\n\
+and CAT2, and a multibyte character C1 which has CAT1 is followed by\n\
+C2 which has CAT2, there's no word boundary between C1 and C2.\n\
+\n\
+For instance, to tell that ASCII characters and Latin-1 characters can\n\
+form a single word, the element `(?l . ?l)' should be in this list\n\
+because both characters have the category `l' (Latin characters).\n\
+\n\
+(2) The case that character are in the same charset is controlled by\n\
+the variable `word-separating-categories'.\n\
+\n\
+Emacs find a word boundary between characters of the same charset\n\
+if they have categories matching some element of this list.\n\
+\n\
+More precisely, if an element of this list is a cons of category CAT1\n\
+and CAT2, and a multibyte character C1 which has CAT1 is followed by\n\
+C2 which has CAT2, there's a word boundary between C1 and C2.\n\
+\n\
+For instance, to tell that there's a word boundary between Japanese\n\
+Hiragana and Japanese Kanji (both are in the same charset), the\n\
+element `(?H . ?C) should be in this list.");
+
+ Vword_combining_categories = Qnil;
+
+ DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories,
+ "List of pair (cons) of categories to determine word boundary.\n\
+See the documentation of the variable `word-combining-categories'.");
+
+ Vword_separating_categories = Qnil;
+
+ defsubr (&Smake_category_set);
+ defsubr (&Sdefine_category);
+ defsubr (&Scategory_docstring);
+ defsubr (&Sget_unused_category);
+ defsubr (&Scategory_table_p);
+ defsubr (&Scategory_table);
+ defsubr (&Sstandard_category_table);
+ defsubr (&Scopy_category_table);
+ defsubr (&Sset_category_table);
+ defsubr (&Schar_category_set);
+ defsubr (&Scategory_set_mnemonics);
+ defsubr (&Smodify_category_entry);
+ defsubr (&Sdescribe_category);
+
+ category_table_version = 0;
+}
--- /dev/null
+/* Declarations having to do with Emacs category tables.
+ Ver.1.0
+
+ Copyright (C) 1995 Free Software Foundation, Inc.
+ Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+/* We introduce here three types of object: category, category set,
+ and category table.
+
+ A category is like syntax but differs in the following points:
+
+ o A category is represented by a mnemonic character of the range
+ ` '(32)..`~'(126) (printable ASCII characters).
+
+ o A category is not exclusive, i.e. a character has multiple
+ categories (category set). Of course, there's a case that a
+ category set is empty, i.e. the character has no category.
+
+ o In addition to the predefined categories, a user can define new
+ categories. Total number of categories is limited to 95.
+
+ A category set is a set of categories represented by Lisp
+ bool-vector of length 128 (only elements of 31th through 125th
+ are used).
+
+ A category table is like syntax-table, represented by a Lisp
+ char-table. The contents are category sets or nil. It has two
+ extra slots. for a vector of doc string of each category and a
+ version number.
+
+ The first extra slot is a vector of doc strings of categories, the
+ length is 95. The Nth element corresponding to the category N+32.
+
+ The second extra slot is a version number of the category table.
+ But, for the moment, we are not using this slot. */
+
+#define CATEGORYP(x) \
+ (INTEGERP ((x)) && XFASTINT ((x)) >= 0x20 && XFASTINT ((x)) <= 0x7E)
+
+#define CHECK_CATEGORY(x, i) \
+ do { \
+ if (!CATEGORYP ((x))) x = wrong_type_argument (Qcategoryp, (x)); \
+ } while (0)
+
+#define XCATEGORY_SET XBOOL_VECTOR
+
+#define CATEGORY_SET_P(x) \
+ (BOOL_VECTOR_P ((x)) && (EMACS_INT) (XBOOL_VECTOR ((x))->size) == 128)
+
+/* Return a new empty category set. */
+#define MAKE_CATEGORY_SET (Fmake_bool_vector (make_number (128), Qnil))
+
+/* Make CATEGORY_SET includes (if VAL is t) or excludes (if VAL is
+ nil) CATEGORY. */
+#define SET_CATEGORY_SET(category_set, category, val) \
+ (Faset (category_set, category, val))
+
+#define CHECK_CATEGORY_SET(x, i) \
+ do { \
+ if (!CATEGORY_SET_P ((x))) x = wrong_type_argument (Qcategorysetp, (x)); \
+ } while (0)
+
+/* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
+ The faster version of `!NILP (Faref (category_set, category))'. */
+#define CATEGORY_MEMBER(category, category_set) \
+ (!NILP (category_set) \
+ && (XCATEGORY_SET (category_set)->data[XFASTINT (category) / 8] \
+ & (1 << (XFASTINT (category) % 8))))
+
+/* Temporary internal variable used in macro CHAR_HAS_CATEGORY. */
+extern Lisp_Object _temp_category_set;
+
+/* Return 1 if category set of CH contains CATEGORY, elt return 0. */
+#define CHAR_HAS_CATEGORY(ch, category) \
+ (_temp_category_set = CATEGORY_SET (ch), \
+ CATEGORY_MEMBER (category, _temp_category_set))
+
+/* The standard category table is stored where it will automatically
+ be used in all new buffers. */
+#define Vstandard_category_table buffer_defaults.category_table
+
+/* Return the category set of character C in the current category table. */
+#ifdef __GNUC__
+#define CATEGORY_SET(c) \
+ ({ Lisp_Object table = current_buffer->category_table; \
+ Lisp_Object temp; \
+ if (c < CHAR_TABLE_ORDINARY_SLOTS) \
+ while (NILP (temp = XCHAR_TABLE (table)->contents[c]) \
+ && NILP (temp = XCHAR_TABLE (table)->defalt)) \
+ table = XCHAR_TABLE (table)->parent; \
+ else \
+ temp = Faref (table, c); \
+ temp; })
+#else
+#define CATEGORY_SET(c) Faref (current_buffer->category_table, c)
+#endif
+
+/* Return the doc string of CATEGORY in category table TABLE. */
+#define CATEGORY_DOCSTRING(table, category) \
+ XVECTOR (Fchar_table_extra_slot (table, 0))->contents[(category) - ' ']
+
+/* Return the version number of category table TABLE. Not used for
+ the moment. */
+#define CATEGORY_TABLE_VERSION (table) \
+ Fchar_table_extra_slot (table, 1)
+
+/* Return 1 if there is a word boundary between two word-constituent
+ characters C1 and C2 if they appear in this order, else return 0.
+ There is no word boundary between two word-constituent ASCII
+ characters. */
+#define WORD_BOUNDARY_P(c1, c2) \
+ (!(SINGLE_BYTE_CHAR_P (c1) && SINGLE_BYTE_CHAR_P (c2)) \
+ && word_boundary_p (c1, c2))
--- /dev/null
+/* CCL (Code Conversion Language) interpreter.
+ Ver.1.0
+
+ Copyright (C) 1995 Free Software Foundation, Inc.
+ Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include <stdio.h>
+
+#ifdef emacs
+
+#include <config.h>
+#include "lisp.h"
+#include "charset.h"
+#include "ccl.h"
+#include "coding.h"
+
+#else /* not emacs */
+
+#include "mulelib.h"
+
+#endif /* not emacs */
+
+/* Alist of fontname patterns vs corresponding CCL program. */
+Lisp_Object Vfont_ccl_encoder_alist;
+
+/* Vector of CCL program names vs corresponding program data. */
+Lisp_Object Vccl_program_table;
+
+/* CCL (Code Conversion Language) is a simple language which has
+ operations on one input buffer, one output buffer, and 7 registers.
+ The syntax of CCL is described in `ccl.el'. Emacs Lisp function
+ `ccl-compile' compiles a CCL program and produces a CCL code which
+ is a vector of integers. The structure of this vector is as
+ follows: The 1st element: buffer-magnification, a factor for the
+ size of output buffer compared with the size of input buffer. The
+ 2nd element: address of CCL code to be executed when encountered
+ with end of input stream. The 3rd and the remaining elements: CCL
+ codes. */
+
+/* Header of CCL compiled code */
+#define CCL_HEADER_BUF_MAG 0
+#define CCL_HEADER_EOF 1
+#define CCL_HEADER_MAIN 2
+
+/* CCL code is a sequence of 28-bit non-negative integers (i.e. the
+ MSB is always 0), each contains CCL command and/or arguments in the
+ following format:
+
+ |----------------- integer (28-bit) ------------------|
+ |------- 17-bit ------|- 3-bit --|- 3-bit --|- 5-bit -|
+ |--constant argument--|-register-|-register-|-command-|
+ ccccccccccccccccc RRR rrr XXXXX
+ or
+ |------- relative address -------|-register-|-command-|
+ cccccccccccccccccccc rrr XXXXX
+ or
+ |------------- constant or other args ----------------|
+ cccccccccccccccccccccccccccc
+
+ where, `cc...c' is a non-negative integer indicating constant value
+ (the left most `c' is always 0) or an absolute jump address, `RRR'
+ and `rrr' are CCL register number, `XXXXX' is one of the following
+ CCL commands. */
+
+/* CCL commands
+
+ Each comment fields shows one or more lines for command syntax and
+ the following lines for semantics of the command. In semantics, IC
+ stands for Instruction Counter. */
+
+#define CCL_SetRegister 0x00 /* Set register a register value:
+ 1:00000000000000000RRRrrrXXXXX
+ ------------------------------
+ reg[rrr] = reg[RRR];
+ */
+
+#define CCL_SetShortConst 0x01 /* Set register a short constant value:
+ 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
+ ------------------------------
+ reg[rrr] = CCCCCCCCCCCCCCCCCCC;
+ */
+
+#define CCL_SetConst 0x02 /* Set register a constant value:
+ 1:00000000000000000000rrrXXXXX
+ 2:CONSTANT
+ ------------------------------
+ reg[rrr] = CONSTANT;
+ IC++;
+ */
+
+#define CCL_SetArray 0x03 /* Set register an element of array:
+ 1:CCCCCCCCCCCCCCCCCRRRrrrXXXXX
+ 2:ELEMENT[0]
+ 3:ELEMENT[1]
+ ...
+ ------------------------------
+ if (0 <= reg[RRR] < CC..C)
+ reg[rrr] = ELEMENT[reg[RRR]];
+ IC += CC..C;
+ */
+
+#define CCL_Jump 0x04 /* Jump:
+ 1:A--D--D--R--E--S--S-000XXXXX
+ ------------------------------
+ IC += ADDRESS;
+ */
+
+/* Note: If CC..C is greater than 0, the second code is omitted. */
+
+#define CCL_JumpCond 0x05 /* Jump conditional:
+ 1:A--D--D--R--E--S--S-rrrXXXXX
+ ------------------------------
+ if (!reg[rrr])
+ IC += ADDRESS;
+ */
+
+
+#define CCL_WriteRegisterJump 0x06 /* Write register and jump:
+ 1:A--D--D--R--E--S--S-rrrXXXXX
+ ------------------------------
+ write (reg[rrr]);
+ IC += ADDRESS;
+ */
+
+#define CCL_WriteRegisterReadJump 0x07 /* Write register, read, and jump:
+ 1:A--D--D--R--E--S--S-rrrXXXXX
+ 2:A--D--D--R--E--S--S-rrrYYYYY
+ -----------------------------
+ write (reg[rrr]);
+ IC++;
+ read (reg[rrr]);
+ IC += ADDRESS;
+ */
+/* Note: If read is suspended, the resumed execution starts from the
+ second code (YYYYY == CCL_ReadJump). */
+
+#define CCL_WriteConstJump 0x08 /* Write constant and jump:
+ 1:A--D--D--R--E--S--S-000XXXXX
+ 2:CONST
+ ------------------------------
+ write (CONST);
+ IC += ADDRESS;
+ */
+
+#define CCL_WriteConstReadJump 0x09 /* Write constant, read, and jump:
+ 1:A--D--D--R--E--S--S-rrrXXXXX
+ 2:CONST
+ 3:A--D--D--R--E--S--S-rrrYYYYY
+ -----------------------------
+ write (CONST);
+ IC += 2;
+ read (reg[rrr]);
+ IC += ADDRESS;
+ */
+/* Note: If read is suspended, the resumed execution starts from the
+ second code (YYYYY == CCL_ReadJump). */
+
+#define CCL_WriteStringJump 0x0A /* Write string and jump:
+ 1:A--D--D--R--E--S--S-000XXXXX
+ 2:LENGTH
+ 3:0000STRIN[0]STRIN[1]STRIN[2]
+ ...
+ ------------------------------
+ write_string (STRING, LENGTH);
+ IC += ADDRESS;
+ */
+
+#define CCL_WriteArrayReadJump 0x0B /* Write an array element, read, and jump:
+ 1:A--D--D--R--E--S--S-rrrXXXXX
+ 2:LENGTH
+ 3:ELEMENET[0]
+ 4:ELEMENET[1]
+ ...
+ N:A--D--D--R--E--S--S-rrrYYYYY
+ ------------------------------
+ if (0 <= reg[rrr] < LENGTH)
+ write (ELEMENT[reg[rrr]]);
+ IC += LENGTH + 2; (... pointing at N+1)
+ read (reg[rrr]);
+ IC += ADDRESS;
+ */
+/* Note: If read is suspended, the resumed execution starts from the
+ Mth code (YYYYY == CCL_ReadJump). */
+
+#define CCL_ReadJump 0x0C /* Read and jump:
+ 1:A--D--D--R--E--S--S-rrrYYYYY
+ -----------------------------
+ read (reg[rrr]);
+ IC += ADDRESS;
+ */
+
+#define CCL_Branch 0x0D /* Jump by branch table:
+ 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
+ 2:A--D--D--R--E-S-S[0]000XXXXX
+ 3:A--D--D--R--E-S-S[1]000XXXXX
+ ...
+ ------------------------------
+ if (0 <= reg[rrr] < CC..C)
+ IC += ADDRESS[reg[rrr]];
+ else
+ IC += ADDRESS[CC..C];
+ */
+
+#define CCL_ReadRegister 0x0E /* Read bytes into registers:
+ 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
+ 2:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
+ ...
+ ------------------------------
+ while (CCC--)
+ read (reg[rrr]);
+ */
+
+#define CCL_WriteExprConst 0x0F /* write result of expression:
+ 1:00000OPERATION000RRR000XXXXX
+ 2:CONSTANT
+ ------------------------------
+ write (reg[RRR] OPERATION CONSTANT);
+ IC++;
+ */
+
+/* Note: If the Nth read is suspended, the resumed execution starts
+ from the Nth code. */
+
+#define CCL_ReadBranch 0x10 /* Read one byte into a register,
+ and jump by branch table:
+ 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
+ 2:A--D--D--R--E-S-S[0]000XXXXX
+ 3:A--D--D--R--E-S-S[1]000XXXXX
+ ...
+ ------------------------------
+ read (read[rrr]);
+ if (0 <= reg[rrr] < CC..C)
+ IC += ADDRESS[reg[rrr]];
+ else
+ IC += ADDRESS[CC..C];
+ */
+
+#define CCL_WriteRegister 0x11 /* Write registers:
+ 1:CCCCCCCCCCCCCCCCCCCrrrXXXXX
+ 2:CCCCCCCCCCCCCCCCCCCrrrXXXXX
+ ...
+ ------------------------------
+ while (CCC--)
+ write (reg[rrr]);
+ ...
+ */
+
+/* Note: If the Nth write is suspended, the resumed execution
+ starts from the Nth code. */
+
+#define CCL_WriteExprRegister 0x12 /* Write result of expression
+ 1:00000OPERATIONRrrRRR000XXXXX
+ ------------------------------
+ write (reg[RRR] OPERATION reg[Rrr]);
+ */
+
+#define CCL_Call 0x13 /* Write a constant:
+ 1:CCCCCCCCCCCCCCCCCCCC000XXXXX
+ ------------------------------
+ call (CC..C)
+ */
+
+#define CCL_WriteConstString 0x14 /* Write a constant or a string:
+ 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
+ [2:0000STRIN[0]STRIN[1]STRIN[2]]
+ [...]
+ -----------------------------
+ if (!rrr)
+ write (CC..C)
+ else
+ write_string (STRING, CC..C);
+ IC += (CC..C + 2) / 3;
+ */
+
+#define CCL_WriteArray 0x15 /* Write an element of array:
+ 1:CCCCCCCCCCCCCCCCCCCCrrrXXXXX
+ 2:ELEMENT[0]
+ 3:ELEMENT[1]
+ ...
+ ------------------------------
+ if (0 <= reg[rrr] < CC..C)
+ write (ELEMENT[reg[rrr]]);
+ IC += CC..C;
+ */
+
+#define CCL_End 0x16 /* Terminate:
+ 1:00000000000000000000000XXXXX
+ ------------------------------
+ terminate ();
+ */
+
+/* The following two codes execute an assignment arithmetic/logical
+ operation. The form of the operation is like REG OP= OPERAND. */
+
+#define CCL_ExprSelfConst 0x17 /* REG OP= constant:
+ 1:00000OPERATION000000rrrXXXXX
+ 2:CONSTANT
+ ------------------------------
+ reg[rrr] OPERATION= CONSTANT;
+ */
+
+#define CCL_ExprSelfReg 0x18 /* REG1 OP= REG2:
+ 1:00000OPERATION000RRRrrrXXXXX
+ ------------------------------
+ reg[rrr] OPERATION= reg[RRR];
+ */
+
+/* The following codes execute an arithmetic/logical operation. The
+ form of the operation is like REG_X = REG_Y OP OPERAND2. */
+
+#define CCL_SetExprConst 0x19 /* REG_X = REG_Y OP constant:
+ 1:00000OPERATION000RRRrrrXXXXX
+ 2:CONSTANT
+ ------------------------------
+ reg[rrr] = reg[RRR] OPERATION CONSTANT;
+ IC++;
+ */
+
+#define CCL_SetExprReg 0x1A /* REG1 = REG2 OP REG3:
+ 1:00000OPERATIONRrrRRRrrrXXXXX
+ ------------------------------
+ reg[rrr] = reg[RRR] OPERATION reg[Rrr];
+ */
+
+#define CCL_JumpCondExprConst 0x1B /* Jump conditional according to
+ an operation on constant:
+ 1:A--D--D--R--E--S--S-rrrXXXXX
+ 2:OPERATION
+ 3:CONSTANT
+ -----------------------------
+ reg[7] = reg[rrr] OPERATION CONSTANT;
+ if (!(reg[7]))
+ IC += ADDRESS;
+ else
+ IC += 2
+ */
+
+#define CCL_JumpCondExprReg 0x1C /* Jump conditional according to
+ an operation on register:
+ 1:A--D--D--R--E--S--S-rrrXXXXX
+ 2:OPERATION
+ 3:RRR
+ -----------------------------
+ reg[7] = reg[rrr] OPERATION reg[RRR];
+ if (!reg[7])
+ IC += ADDRESS;
+ else
+ IC += 2;
+ */
+
+#define CCL_ReadJumpCondExprConst 0x1D /* Read and jump conditional according
+ to an operation on constant:
+ 1:A--D--D--R--E--S--S-rrrXXXXX
+ 2:OPERATION
+ 3:CONSTANT
+ -----------------------------
+ read (reg[rrr]);
+ reg[7] = reg[rrr] OPERATION CONSTANT;
+ if (!reg[7])
+ IC += ADDRESS;
+ else
+ IC += 2;
+ */
+
+#define CCL_ReadJumpCondExprReg 0x1E /* Read and jump conditional according
+ to an operation on register:
+ 1:A--D--D--R--E--S--S-rrrXXXXX
+ 2:OPERATION
+ 3:RRR
+ -----------------------------
+ read (reg[rrr]);
+ reg[7] = reg[rrr] OPERATION reg[RRR];
+ if (!reg[7])
+ IC += ADDRESS;
+ else
+ IC += 2;
+ */
+
+#define CCL_Extention 0x1F /* Extended CCL code
+ 1:ExtendedCOMMNDRrrRRRrrrXXXXX
+ 2:ARGUEMENT
+ 3:...
+ ------------------------------
+ extended_command (rrr,RRR,Rrr,ARGS)
+ */
+
+
+/* CCL arithmetic/logical operators. */
+#define CCL_PLUS 0x00 /* X = Y + Z */
+#define CCL_MINUS 0x01 /* X = Y - Z */
+#define CCL_MUL 0x02 /* X = Y * Z */
+#define CCL_DIV 0x03 /* X = Y / Z */
+#define CCL_MOD 0x04 /* X = Y % Z */
+#define CCL_AND 0x05 /* X = Y & Z */
+#define CCL_OR 0x06 /* X = Y | Z */
+#define CCL_XOR 0x07 /* X = Y ^ Z */
+#define CCL_LSH 0x08 /* X = Y << Z */
+#define CCL_RSH 0x09 /* X = Y >> Z */
+#define CCL_LSH8 0x0A /* X = (Y << 8) | Z */
+#define CCL_RSH8 0x0B /* X = Y >> 8, r[7] = Y & 0xFF */
+#define CCL_DIVMOD 0x0C /* X = Y / Z, r[7] = Y % Z */
+#define CCL_LS 0x10 /* X = (X < Y) */
+#define CCL_GT 0x11 /* X = (X > Y) */
+#define CCL_EQ 0x12 /* X = (X == Y) */
+#define CCL_LE 0x13 /* X = (X <= Y) */
+#define CCL_GE 0x14 /* X = (X >= Y) */
+#define CCL_NE 0x15 /* X = (X != Y) */
+
+#define CCL_ENCODE_SJIS 0x16 /* X = HIGHER_BYTE (SJIS (Y, Z))
+ r[7] = LOWER_BYTE (SJIS (Y, Z) */
+#define CCL_DECODE_SJIS 0x17 /* X = HIGHER_BYTE (DE-SJIS (Y, Z))
+ r[7] = LOWER_BYTE (DE-SJIS (Y, Z)) */
+
+/* Macros for exit status of CCL program. */
+#define CCL_STAT_SUCCESS 0 /* Terminated successfully. */
+#define CCL_STAT_SUSPEND 1 /* Terminated because of empty input
+ buffer or full output buffer. */
+#define CCL_STAT_INVALID_CMD 2 /* Terminated because of invalid
+ command. */
+#define CCL_STAT_QUIT 3 /* Terminated because of quit. */
+
+/* Terminate CCL program successfully. */
+#define CCL_SUCCESS \
+ do { \
+ ccl->status = CCL_STAT_SUCCESS; \
+ ccl->ic = CCL_HEADER_MAIN; \
+ goto ccl_finish; \
+ } while (0)
+
+/* Suspend CCL program because of reading from empty input buffer or
+ writing to full output buffer. When this program is resumed, the
+ same I/O command is executed. */
+#define CCL_SUSPEND \
+ do { \
+ ic--; \
+ ccl->status = CCL_STAT_SUSPEND; \
+ goto ccl_finish; \
+ } while (0)
+
+/* Terminate CCL program because of invalid command. Should not occur
+ in the normal case. */
+#define CCL_INVALID_CMD \
+ do { \
+ ccl->status = CCL_STAT_INVALID_CMD; \
+ goto ccl_error_handler; \
+ } while (0)
+
+/* Encode one character CH to multibyte form and write to the current
+ output buffer. If CH is negative, write one byte -CH. */
+#define CCL_WRITE_CHAR(ch) \
+ do { \
+ if (!dst) \
+ CCL_INVALID_CMD; \
+ else \
+ { \
+ unsigned char work[4], *str; \
+ int len = CHAR_STRING (ch, work, str); \
+ if (dst + len <= dst_end) \
+ { \
+ bcopy (str, dst, len); \
+ dst += len; \
+ } \
+ else \
+ CCL_SUSPEND; \
+ } \
+ } while (0)
+
+/* Write a string at ccl_prog[IC] of length LEN to the current output
+ buffer. */
+#define CCL_WRITE_STRING(len) \
+ do { \
+ if (!dst) \
+ CCL_INVALID_CMD; \
+ else if (dst + len <= dst_end) \
+ for (i = 0; i < len; i++) \
+ *dst++ = ((XFASTINT (ccl_prog[ic + (i / 3)])) \
+ >> ((2 - (i % 3)) * 8)) & 0xFF; \
+ else \
+ CCL_SUSPEND; \
+ } while (0)
+
+/* Read one byte from the current input buffer into Rth register. */
+#define CCL_READ_CHAR(r) \
+ do { \
+ if (!src) \
+ CCL_INVALID_CMD; \
+ else if (src < src_end) \
+ r = *src++; \
+ else if (ccl->last_block) \
+ { \
+ ic = ccl->eof_ic; \
+ goto ccl_finish; \
+ } \
+ else \
+ CCL_SUSPEND; \
+ } while (0)
+
+
+/* Execute CCL code on SRC_BYTES length text at SOURCE. The resulting
+ text goes to a place pointed by DESTINATION, the length of which
+ should not exceed DST_BYTES. The bytes actually processed is
+ returned as *CONSUMED. The return value is the length of the
+ resulting text. As a side effect, the contents of CCL registers
+ are updated. If SOURCE or DESTINATION is NULL, only operations on
+ registers are permitted. */
+
+#ifdef CCL_DEBUG
+#define CCL_DEBUG_BACKTRACE_LEN 256
+int ccl_backtrace_table[CCL_BACKTRACE_TABLE];
+int ccl_backtrace_idx;
+#endif
+
+struct ccl_prog_stack
+ {
+ int *ccl_prog; /* Pointer to an array of CCL code. */
+ int ic; /* Instruction Counter. */
+ };
+
+ccl_driver (ccl, source, destination, src_bytes, dst_bytes, consumed)
+ struct ccl_program *ccl;
+ unsigned char *source, *destination;
+ int src_bytes, dst_bytes;
+ int *consumed;
+{
+ register int *reg = ccl->reg;
+ register int ic = ccl->ic;
+ register int code, field1, field2;
+ register int *ccl_prog = ccl->prog;
+ unsigned char *src = source, *src_end = src + src_bytes;
+ unsigned char *dst = destination, *dst_end = dst + dst_bytes;
+ int jump_address;
+ int i, j, op;
+ int stack_idx = 0;
+ /* For the moment, we only support depth 256 of stack. */
+ struct ccl_prog_stack ccl_prog_stack_struct[256];
+
+ if (ic >= ccl->eof_ic)
+ ic = CCL_HEADER_MAIN;
+
+#ifdef CCL_DEBUG
+ ccl_backtrace_idx = 0;
+#endif
+
+ for (;;)
+ {
+#ifdef CCL_DEBUG
+ ccl_backtrace_table[ccl_backtrace_idx++] = ic;
+ if (ccl_backtrace_idx >= CCL_DEBUG_BACKTRACE_LEN)
+ ccl_backtrace_idx = 0;
+ ccl_backtrace_table[ccl_backtrace_idx] = 0;
+#endif
+
+ if (!NILP (Vquit_flag) && NILP (Vinhibit_quit))
+ {
+ /* We can't just signal Qquit, instead break the loop as if
+ the whole data is processed. Don't reset Vquit_flag, it
+ must be handled later at a safer place. */
+ if (consumed)
+ src = source + src_bytes;
+ ccl->status = CCL_STAT_QUIT;
+ break;
+ }
+
+ code = XINT (ccl_prog[ic]); ic++;
+ field1 = code >> 8;
+ field2 = (code & 0xFF) >> 5;
+
+#define rrr field2
+#define RRR (field1 & 7)
+#define Rrr ((field1 >> 3) & 7)
+#define ADDR field1
+
+ switch (code & 0x1F)
+ {
+ case CCL_SetRegister: /* 00000000000000000RRRrrrXXXXX */
+ reg[rrr] = reg[RRR];
+ break;
+
+ case CCL_SetShortConst: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
+ reg[rrr] = field1;
+ break;
+
+ case CCL_SetConst: /* 00000000000000000000rrrXXXXX */
+ reg[rrr] = XINT (ccl_prog[ic]);
+ ic++;
+ break;
+
+ case CCL_SetArray: /* CCCCCCCCCCCCCCCCCCCCRRRrrrXXXXX */
+ i = reg[RRR];
+ j = field1 >> 3;
+ if ((unsigned int) i < j)
+ reg[rrr] = XINT (ccl_prog[ic + i]);
+ ic += j;
+ break;
+
+ case CCL_Jump: /* A--D--D--R--E--S--S-000XXXXX */
+ ic += ADDR;
+ break;
+
+ case CCL_JumpCond: /* A--D--D--R--E--S--S-rrrXXXXX */
+ if (!reg[rrr])
+ ic += ADDR;
+ break;
+
+ case CCL_WriteRegisterJump: /* A--D--D--R--E--S--S-rrrXXXXX */
+ i = reg[rrr];
+ CCL_WRITE_CHAR (i);
+ ic += ADDR;
+ break;
+
+ case CCL_WriteRegisterReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
+ i = reg[rrr];
+ CCL_WRITE_CHAR (i);
+ ic++;
+ CCL_READ_CHAR (reg[rrr]);
+ ic += ADDR - 1;
+ break;
+
+ case CCL_WriteConstJump: /* A--D--D--R--E--S--S-000XXXXX */
+ i = XINT (ccl_prog[ic]);
+ CCL_WRITE_CHAR (i);
+ ic += ADDR;
+ break;
+
+ case CCL_WriteConstReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
+ i = XINT (ccl_prog[ic]);
+ CCL_WRITE_CHAR (i);
+ ic++;
+ CCL_READ_CHAR (reg[rrr]);
+ ic += ADDR - 1;
+ break;
+
+ case CCL_WriteStringJump: /* A--D--D--R--E--S--S-000XXXXX */
+ j = XINT (ccl_prog[ic]);
+ ic++;
+ CCL_WRITE_STRING (j);
+ ic += ADDR - 1;
+ break;
+
+ case CCL_WriteArrayReadJump: /* A--D--D--R--E--S--S-rrrXXXXX */
+ i = reg[rrr];
+ j = ccl_prog[ic++];
+ if ((unsigned int) i < j)
+ {
+ i = XINT (ccl_prog[ic + i]);
+ CCL_WRITE_CHAR (i);
+ }
+ ic += j + 1;
+ CCL_READ_CHAR (reg[rrr]);
+ ic += ADDR - (j + 2);
+ break;
+
+ case CCL_ReadJump: /* A--D--D--R--E--S--S-rrrYYYYY */
+ CCL_READ_CHAR (reg[rrr]);
+ ic += ADDR;
+ break;
+
+ case CCL_ReadBranch: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
+ CCL_READ_CHAR (reg[rrr]);
+ /* fall through ... */
+ case CCL_Branch: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
+ if ((unsigned int) reg[rrr] < field1)
+ ic += XINT (ccl_prog[ic + reg[rrr]]);
+ else
+ ic += XINT (ccl_prog[ic + field1]);
+ break;
+
+ case CCL_ReadRegister: /* CCCCCCCCCCCCCCCCCCCCrrXXXXX */
+ while (1)
+ {
+ CCL_READ_CHAR (reg[rrr]);
+ if (!field1) break;
+ code = XINT (ccl_prog[ic]); ic++;
+ field1 = code >> 8;
+ field2 = (code & 0xFF) >> 5;
+ }
+ break;
+
+ case CCL_WriteExprConst: /* 1:00000OPERATION000RRR000XXXXX */
+ rrr = 7;
+ i = reg[RRR];
+ j = XINT (ccl_prog[ic]);
+ op = field1 >> 6;
+ ic++;
+ goto ccl_set_expr;
+
+ case CCL_WriteRegister: /* CCCCCCCCCCCCCCCCCCCrrrXXXXX */
+ while (1)
+ {
+ i = reg[rrr];
+ CCL_WRITE_CHAR (i);
+ if (!field1) break;
+ code = XINT (ccl_prog[ic]); ic++;
+ field1 = code >> 8;
+ field2 = (code & 0xFF) >> 5;
+ }
+ break;
+
+ case CCL_WriteExprRegister: /* 1:00000OPERATIONRrrRRR000XXXXX */
+ rrr = 7;
+ i = reg[RRR];
+ j = reg[Rrr];
+ op = field1 >> 6;
+ goto ccl_set_expr;
+
+ case CCL_Call: /* CCCCCCCCCCCCCCCCCCCC000XXXXX */
+ {
+ Lisp_Object slot;
+
+ if (stack_idx >= 256
+ || field1 < 0
+ || field1 >= XVECTOR (Vccl_program_table)->size
+ || (slot = XVECTOR (Vccl_program_table)->contents[field1],
+ !CONSP (slot))
+ || !VECTORP (XCONS (slot)->cdr))
+ {
+ if (stack_idx > 0)
+ {
+ ccl_prog = ccl_prog_stack_struct[0].ccl_prog;
+ ic = ccl_prog_stack_struct[0].ic;
+ }
+ CCL_INVALID_CMD;
+ }
+
+ ccl_prog_stack_struct[stack_idx].ccl_prog = ccl_prog;
+ ccl_prog_stack_struct[stack_idx].ic = ic;
+ stack_idx++;
+ ccl_prog = XVECTOR (XCONS (slot)->cdr)->contents;
+ ic = CCL_HEADER_MAIN;
+ }
+ break;
+
+ case CCL_WriteConstString: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
+ if (!rrr)
+ CCL_WRITE_CHAR (field1);
+ else
+ {
+ CCL_WRITE_STRING (field1);
+ ic += (field1 + 2) / 3;
+ }
+ break;
+
+ case CCL_WriteArray: /* CCCCCCCCCCCCCCCCCCCCrrrXXXXX */
+ i = reg[rrr];
+ if ((unsigned int) i < field1)
+ {
+ j = XINT (ccl_prog[ic + i]);
+ CCL_WRITE_CHAR (j);
+ }
+ ic += field1;
+ break;
+
+ case CCL_End: /* 0000000000000000000000XXXXX */
+ if (stack_idx-- > 0)
+ {
+ ccl_prog = ccl_prog_stack_struct[stack_idx].ccl_prog;
+ ic = ccl_prog_stack_struct[stack_idx].ic;
+ break;
+ }
+ CCL_SUCCESS;
+
+ case CCL_ExprSelfConst: /* 00000OPERATION000000rrrXXXXX */
+ i = XINT (ccl_prog[ic]);
+ ic++;
+ op = field1 >> 6;
+ goto ccl_expr_self;
+
+ case CCL_ExprSelfReg: /* 00000OPERATION000RRRrrrXXXXX */
+ i = reg[RRR];
+ op = field1 >> 6;
+
+ ccl_expr_self:
+ switch (op)
+ {
+ case CCL_PLUS: reg[rrr] += i; break;
+ case CCL_MINUS: reg[rrr] -= i; break;
+ case CCL_MUL: reg[rrr] *= i; break;
+ case CCL_DIV: reg[rrr] /= i; break;
+ case CCL_MOD: reg[rrr] %= i; break;
+ case CCL_AND: reg[rrr] &= i; break;
+ case CCL_OR: reg[rrr] |= i; break;
+ case CCL_XOR: reg[rrr] ^= i; break;
+ case CCL_LSH: reg[rrr] <<= i; break;
+ case CCL_RSH: reg[rrr] >>= i; break;
+ case CCL_LSH8: reg[rrr] <<= 8; reg[rrr] |= i; break;
+ case CCL_RSH8: reg[7] = reg[rrr] & 0xFF; reg[rrr] >>= 8; break;
+ case CCL_DIVMOD: reg[7] = reg[rrr] % i; reg[rrr] /= i; break;
+ case CCL_LS: reg[rrr] = reg[rrr] < i; break;
+ case CCL_GT: reg[rrr] = reg[rrr] > i; break;
+ case CCL_EQ: reg[rrr] = reg[rrr] == i; break;
+ case CCL_LE: reg[rrr] = reg[rrr] <= i; break;
+ case CCL_GE: reg[rrr] = reg[rrr] >= i; break;
+ case CCL_NE: reg[rrr] = reg[rrr] != i; break;
+ default: CCL_INVALID_CMD;
+ }
+ break;
+
+ case CCL_SetExprConst: /* 00000OPERATION000RRRrrrXXXXX */
+ i = reg[RRR];
+ j = XINT (ccl_prog[ic]);
+ op = field1 >> 6;
+ jump_address = ++ic;
+ goto ccl_set_expr;
+
+ case CCL_SetExprReg: /* 00000OPERATIONRrrRRRrrrXXXXX */
+ i = reg[RRR];
+ j = reg[Rrr];
+ op = field1 >> 6;
+ jump_address = ic;
+ goto ccl_set_expr;
+
+ case CCL_ReadJumpCondExprConst: /* A--D--D--R--E--S--S-rrrXXXXX */
+ CCL_READ_CHAR (reg[rrr]);
+ case CCL_JumpCondExprConst: /* A--D--D--R--E--S--S-rrrXXXXX */
+ i = reg[rrr];
+ op = XINT (ccl_prog[ic]);
+ jump_address = ic++ + ADDR;
+ j = XINT (ccl_prog[ic]);
+ ic++;
+ rrr = 7;
+ goto ccl_set_expr;
+
+ case CCL_ReadJumpCondExprReg: /* A--D--D--R--E--S--S-rrrXXXXX */
+ CCL_READ_CHAR (reg[rrr]);
+ case CCL_JumpCondExprReg:
+ i = reg[rrr];
+ op = XINT (ccl_prog[ic]);
+ jump_address = ic++ + ADDR;
+ j = reg[XINT (ccl_prog[ic])];
+ ic++;
+ rrr = 7;
+
+ ccl_set_expr:
+ switch (op)
+ {
+ case CCL_PLUS: reg[rrr] = i + j; break;
+ case CCL_MINUS: reg[rrr] = i - j; break;
+ case CCL_MUL: reg[rrr] = i * j; break;
+ case CCL_DIV: reg[rrr] = i / j; break;
+ case CCL_MOD: reg[rrr] = i % j; break;
+ case CCL_AND: reg[rrr] = i & j; break;
+ case CCL_OR: reg[rrr] = i | j; break;
+ case CCL_XOR: reg[rrr] = i ^ j;; break;
+ case CCL_LSH: reg[rrr] = i << j; break;
+ case CCL_RSH: reg[rrr] = i >> j; break;
+ case CCL_LSH8: reg[rrr] = (i << 8) | j; break;
+ case CCL_RSH8: reg[rrr] = i >> 8; reg[7] = i & 0xFF; break;
+ case CCL_DIVMOD: reg[rrr] = i / j; reg[7] = i % j; break;
+ case CCL_LS: reg[rrr] = i < j; break;
+ case CCL_GT: reg[rrr] = i > j; break;
+ case CCL_EQ: reg[rrr] = i == j; break;
+ case CCL_LE: reg[rrr] = i <= j; break;
+ case CCL_GE: reg[rrr] = i >= j; break;
+ case CCL_NE: reg[rrr] = i != j; break;
+ case CCL_ENCODE_SJIS: ENCODE_SJIS (i, j, reg[rrr], reg[7]); break;
+ case CCL_DECODE_SJIS: DECODE_SJIS (i, j, reg[rrr], reg[7]); break;
+ default: CCL_INVALID_CMD;
+ }
+ code &= 0x1F;
+ if (code == CCL_WriteExprConst || code == CCL_WriteExprRegister)
+ {
+ i = reg[rrr];
+ CCL_WRITE_CHAR (i);
+ }
+ else if (!reg[rrr])
+ ic = jump_address;
+ break;
+
+ default:
+ CCL_INVALID_CMD;
+ }
+ }
+
+ ccl_error_handler:
+ if (destination)
+ {
+ /* We can insert an error message only if DESTINATION is
+ specified and we still have a room to store the message
+ there. */
+ char msg[256];
+ int msglen;
+
+ switch (ccl->status)
+ {
+ case CCL_STAT_INVALID_CMD:
+ sprintf(msg, "\nCCL: Invalid command %x (ccl_code = %x) at %d.",
+ code & 0x1F, code, ic);
+#ifdef CCL_DEBUG
+ {
+ int i = ccl_backtrace_idx - 1;
+ int j;
+
+ msglen = strlen (msg);
+ if (dst + msglen <= dst_end)
+ {
+ bcopy (msg, dst, msglen);
+ dst += msglen;
+ }
+
+ for (j = 0; j < CCL_DEBUG_BACKTRACE_LEN; j++, i--)
+ {
+ if (i < 0) i = CCL_DEBUG_BACKTRACE_LEN - 1;
+ if (ccl_backtrace_table[i] == 0)
+ break;
+ sprintf(msg, " %d", ccl_backtrace_table[i]);
+ msglen = strlen (msg);
+ if (dst + msglen > dst_end)
+ break;
+ bcopy (msg, dst, msglen);
+ dst += msglen;
+ }
+ }
+ goto ccl_finish;
+#endif
+
+ case CCL_STAT_QUIT:
+ sprintf(msg, "\nCCL: Quited.");
+ break;
+
+ default:
+ sprintf(msg, "\nCCL: Unknown error type (%d).", ccl->status);
+ }
+
+ msglen = strlen (msg);
+ if (dst + msglen <= dst_end)
+ {
+ bcopy (msg, dst, msglen);
+ dst += msglen;
+ }
+ }
+
+ ccl_finish:
+ ccl->ic = ic;
+ if (consumed) *consumed = src - source;
+ return dst - destination;
+}
+
+/* Setup fields of the structure pointed by CCL appropriately for the
+ execution of compiled CCL code in VEC (vector of integer). */
+setup_ccl_program (ccl, vec)
+ struct ccl_program *ccl;
+ Lisp_Object vec;
+{
+ int i;
+
+ ccl->size = XVECTOR (vec)->size;
+ ccl->prog = XVECTOR (vec)->contents;
+ ccl->ic = CCL_HEADER_MAIN;
+ ccl->eof_ic = XINT (XVECTOR (vec)->contents[CCL_HEADER_EOF]);
+ ccl->buf_magnification = XINT (XVECTOR (vec)->contents[CCL_HEADER_BUF_MAG]);
+ for (i = 0; i < 8; i++)
+ ccl->reg[i] = 0;
+ ccl->last_block = 0;
+ ccl->status = 0;
+}
+
+#ifdef emacs
+
+DEFUN ("ccl-execute", Fccl_execute, Sccl_execute, 2, 2, 0,
+ "Execute CCL-PROGRAM with registers initialized by REGISTERS.\n\
+CCL-PROGRAM is a compiled code generated by `ccl-compile',\n\
+ no I/O commands should appear in the CCL program.\n\
+REGISTERS is a vector of [R0 R1 ... R7] where RN is an initial value\n\
+ of Nth register.\n\
+As side effect, each element of REGISTER holds the value of\n\
+ corresponding register after the execution.")
+ (ccl_prog, reg)
+ Lisp_Object ccl_prog, reg;
+{
+ struct ccl_program ccl;
+ int i;
+
+ CHECK_VECTOR (ccl_prog, 0);
+ CHECK_VECTOR (reg, 1);
+ if (XVECTOR (reg)->size != 8)
+ error ("Invalid length of vector REGISTERS");
+
+ setup_ccl_program (&ccl, ccl_prog);
+ for (i = 0; i < 8; i++)
+ ccl.reg[i] = (INTEGERP (XVECTOR (reg)->contents[i])
+ ? XINT (XVECTOR (reg)->contents[i])
+ : 0);
+
+ ccl_driver (&ccl, (char *)0, (char *)0, 0, 0, (int *)0);
+ QUIT;
+ if (ccl.status != CCL_STAT_SUCCESS)
+ error ("Error in CCL program at %dth code", ccl.ic);
+
+ for (i = 0; i < 8; i++)
+ XSETINT (XVECTOR (reg)->contents[i], ccl.reg[i]);
+ return Qnil;
+}
+
+DEFUN ("ccl-execute-on-string", Fccl_execute_on_string, Sccl_execute_on_string,
+ 3, 3, 0,
+ "Execute CCL-PROGRAM with initial STATUS on STRING.\n\
+CCL-PROGRAM is a compiled code generated by `ccl-compile'.\n\
+Read buffer is set to STRING, and write buffer is allocated automatically.\n\
+STATUS is a vector of [R0 R1 ... R7 IC], where\n\
+ R0..R7 are initial values of corresponding registers,\n\
+ IC is the instruction counter specifying from where to start the program.\n\
+If R0..R7 are nil, they are initialized to 0.\n\
+If IC is nil, it is initialized to head of the CCL program.\n\
+Returns the contents of write buffer as a string,\n\
+ and as side effect, STATUS is updated.")
+ (ccl_prog, status, str)
+ Lisp_Object ccl_prog, status, str;
+{
+ Lisp_Object val;
+ struct ccl_program ccl;
+ int i, produced;
+ int outbufsize;
+ char *outbuf;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+
+ CHECK_VECTOR (ccl_prog, 0);
+ CHECK_VECTOR (status, 1);
+ if (XVECTOR (status)->size != 9)
+ error ("Invalid length of vector STATUS");
+ CHECK_STRING (str, 2);
+ GCPRO3 (ccl_prog, status, str);
+
+ setup_ccl_program (&ccl, ccl_prog);
+ for (i = 0; i < 8; i++)
+ {
+ if (NILP (XVECTOR (status)->contents[i]))
+ XSETINT (XVECTOR (status)->contents[i], 0);
+ if (INTEGERP (XVECTOR (status)->contents[i]))
+ ccl.reg[i] = XINT (XVECTOR (status)->contents[i]);
+ }
+ if (INTEGERP (XVECTOR (status)->contents[i]))
+ {
+ i = XFASTINT (XVECTOR (status)->contents[8]);
+ if (ccl.ic < i && i < ccl.size)
+ ccl.ic = i;
+ }
+ outbufsize = XSTRING (str)->size * ccl.buf_magnification + 256;
+ outbuf = (char *) xmalloc (outbufsize);
+ if (!outbuf)
+ error ("Not enough memory");
+ ccl.last_block = 1;
+ produced = ccl_driver (&ccl, XSTRING (str)->data, outbuf,
+ XSTRING (str)->size, outbufsize, (int *)0);
+ for (i = 0; i < 8; i++)
+ XSET (XVECTOR (status)->contents[i], Lisp_Int, ccl.reg[i]);
+ XSETINT (XVECTOR (status)->contents[8], ccl.ic);
+ UNGCPRO;
+
+ val = make_string (outbuf, produced);
+ free (outbuf);
+ QUIT;
+ if (ccl.status != CCL_STAT_SUCCESS
+ && ccl.status != CCL_STAT_SUSPEND)
+ error ("Error in CCL program at %dth code", ccl.ic);
+
+ return val;
+}
+
+DEFUN ("register-ccl-program", Fregister_ccl_program, Sregister_ccl_program,
+ 2, 2, 0,
+ "Register CCL program PROGRAM of NAME in `ccl-program-table'.
+PROGRAM should be a compiled code of CCL program, or nil.
+Return index number of the registered CCL program.")
+ (name, ccl_prog)
+ Lisp_Object name, ccl_prog;
+{
+ int len = XVECTOR (Vccl_program_table)->size;
+ int i, idx;
+
+ CHECK_SYMBOL (name, 0);
+ if (!NILP (ccl_prog))
+ CHECK_VECTOR (ccl_prog, 1);
+
+ for (i = 0; i < len; i++)
+ {
+ Lisp_Object slot = XVECTOR (Vccl_program_table)->contents[i];
+
+ if (!CONSP (slot))
+ break;
+
+ if (EQ (name, XCONS (slot)->car))
+ {
+ XCONS (slot)->cdr = ccl_prog;
+ return make_number (i);
+ }
+ }
+
+ if (i == len)
+ {
+ Lisp_Object new_table = Fmake_vector (len * 2, Qnil);
+ int j;
+
+ for (j = 0; j < len; j++)
+ XVECTOR (new_table)->contents[j]
+ = XVECTOR (Vccl_program_table)->contents[j];
+ Vccl_program_table = new_table;
+ }
+
+ XVECTOR (Vccl_program_table)->contents[i] = Fcons (name, ccl_prog);
+ return make_number (i);
+}
+
+syms_of_ccl ()
+{
+ staticpro (&Vccl_program_table);
+ Vccl_program_table = Fmake_vector (32, Qnil);
+
+ DEFVAR_LISP ("font-ccl-encoder-alist", &Vfont_ccl_encoder_alist,
+ "Alist of fontname patterns vs corresponding CCL program.\n\
+Each element looks like (REGEXP . CCL-CODE),\n\
+ where CCL-CODE is a compiled CCL program.\n\
+When a font whose name matches REGEXP is used for displaying a character,\n\
+ CCL-CODE is executed to calculate the code point in the font\n\
+ from the charset number and position code(s) of the character which are set\n\
+ in CCL registers R0, R1, and R2 before the execution.\n\
+The code point in the font is set in CCL registers R1 and R2\n\
+ when the execution terminated.\n\
+If the font is single-byte font, the register R2 is not used.");
+ Vfont_ccl_encoder_alist = Qnil;
+
+ defsubr (&Sccl_execute);
+ defsubr (&Sccl_execute_on_string);
+ defsubr (&Sregister_ccl_program);
+}
+
+#endif /* emacs */
--- /dev/null
+/* Header for CCL (Code Conversion Language) interpreter.
+
+ Copyright (C) 1995 Free Software Foundation, Inc.
+ Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#ifndef _CCL_H
+#define _CCL_H
+
+/* Structure to hold information about running CCL code. Read
+ comments in the file ccl.c for the detail of each field. */
+struct ccl_program {
+ int size; /* Size of the compiled code. */
+ Lisp_Object *prog; /* Pointer into the compiled code. */
+ int ic; /* Instruction Counter (index for PROG). */
+ int eof_ic; /* Instruction Counter for end-of-file
+ processing code. */
+ int reg[8]; /* CCL registers, reg[7] is used for
+ condition flag of relational
+ operations. */
+ int last_block; /* Set to 1 while processing the last
+ block. */
+ int status; /* Exit status of the CCL program. */
+ int buf_magnification; /* Output buffer magnification. How
+ many times bigger the output buffer
+ should be than the input buffer. */
+};
+
+/* This data type is used for the spec field of the structure
+ coding_system. */
+
+struct ccl_spec {
+ struct ccl_program decoder;
+ struct ccl_program encoder;
+};
+
+/* Alist of fontname patterns vs corresponding CCL program. */
+extern Lisp_Object Vfont_ccl_encoder_alist;
+
+#endif /* _CCL_H */
--- /dev/null
+/* Multilingual characters handler.
+ Ver.1.0
+
+ Copyright (C) 1995 Free Software Foundation, Inc.
+ Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+/* At first, see the document in `charset.h' to understand the code in
+ this file. */
+
+#include <stdio.h>
+
+#ifdef emacs
+
+#include <sys/types.h>
+#include <config.h>
+#include "lisp.h"
+#include "buffer.h"
+#include "charset.h"
+#include "coding.h"
+
+#else /* not emacs */
+
+#include "mulelib.h"
+
+#endif /* emacs */
+
+Lisp_Object Qcharset, Qascii, Qcomposition;
+
+/* Declaration of special leading-codes. */
+int leading_code_composition; /* for composite characters */
+int leading_code_private_11; /* for private DIMENSION1 of 1-column */
+int leading_code_private_12; /* for private DIMENSION1 of 2-column */
+int leading_code_private_21; /* for private DIMENSION2 of 1-column */
+int leading_code_private_22; /* for private DIMENSION2 of 2-column */
+
+/* Declaration of special charsets. */
+int charset_ascii; /* ASCII */
+int charset_composition; /* for a composite character */
+int charset_latin_iso8859_1; /* ISO8859-1 (Latin-1) */
+int charset_jisx0208_1978; /* JISX0208.1978 (Japanese Kanji old set) */
+int charset_jisx0208; /* JISX0208.1983 (Japanese Kanji) */
+int charset_katakana_jisx0201; /* JISX0201.Kana (Japanese Katakana) */
+int charset_latin_jisx0201; /* JISX0201.Roman (Japanese Roman) */
+int charset_big5_1; /* Big5 Level 1 (Chinese Traditional) */
+int charset_big5_2; /* Big5 Level 2 (Chinese Traditional) */
+
+Lisp_Object Qcharset_table;
+
+/* A char-table containing information of each character set. */
+Lisp_Object Vcharset_table;
+
+/* A vector of charset symbol indexed by charset-id. This is used
+ only for returning charset symbol from C functions. */
+Lisp_Object Vcharset_symbol_table;
+
+/* A list of charset symbols ever defined. */
+Lisp_Object Vcharset_list;
+
+/* Tables used by macros BYTES_BY_CHAR_HEAD and WIDTH_BY_CHAR_HEAD. */
+int bytes_by_char_head[256];
+int width_by_char_head[256];
+
+/* Mapping table from ISO2022's charset (specified by DIMENSION,
+ CHARS, and FINAL-CHAR) to Emacs' charset. */
+int iso_charset_table[2][2][128];
+
+/* Variables used locally in the macro FETCH_MULTIBYTE_CHAR. */
+unsigned char *_fetch_multibyte_char_p;
+int _fetch_multibyte_char_len;
+
+/* Set STR a pointer to the multi-byte form of the character C. If C
+ is not a composite character, the multi-byte form is set in WORKBUF
+ and STR points WORKBUF. The caller should allocate at least 4-byte
+ area at WORKBUF in advance. Returns the length of the multi-byte
+ form.
+
+ Use macro `CHAR_STRING (C, WORKBUF, STR)' instead of calling this
+ function directly if C can be an ASCII character. */
+
+int
+non_ascii_char_to_string (c, workbuf, str)
+ int c;
+ unsigned char *workbuf, **str;
+{
+ int charset;
+ unsigned char c1, c2;
+
+ if (COMPOSITE_CHAR_P (c))
+ {
+ int cmpchar_id = COMPOSITE_CHAR_ID (c);
+
+ if (cmpchar_id < n_cmpchars)
+ {
+ *str = cmpchar_table[cmpchar_id]->data;
+ return cmpchar_table[cmpchar_id]->len;
+ }
+ else
+ {
+ *str = workbuf;
+ return 0;
+ }
+ }
+
+ SPLIT_NON_ASCII_CHAR (c, charset, c1, c2);
+
+ *str = workbuf;
+ *workbuf++ = CHARSET_LEADING_CODE_BASE (charset);
+ if (*workbuf = CHARSET_LEADING_CODE_EXT (charset))
+ workbuf++;
+ *workbuf++ = c1 | 0x80;
+ if (c2)
+ *workbuf++ = c2 | 0x80;
+
+ return (workbuf - *str);
+}
+
+/* Return a non-ASCII character of which multi-byte form is at STR of
+ length LEN. If ACTUAL_LEN is not NULL, the actual length of the
+ character is set to the address ACTUAL_LEN.
+
+ Use macro `STRING_CHAR (STR, LEN)' instead of calling this function
+ directly if STR can hold an ASCII character. */
+
+string_to_non_ascii_char (str, len, actual_len)
+ unsigned char *str;
+ int len, *actual_len;
+{
+ int charset;
+ unsigned char c1, c2;
+ register int c;
+
+ if (SPLIT_STRING (str, len, charset, c1, c2) == CHARSET_ASCII)
+ {
+ if (actual_len)
+ *actual_len = 1;
+ return (int) *str;
+ }
+
+ c = MAKE_NON_ASCII_CHAR (charset, c1, c2);
+
+ if (actual_len)
+ *actual_len = (charset == CHARSET_COMPOSITION
+ ? cmpchar_table[COMPOSITE_CHAR_ID (c)]->len
+ : BYTES_BY_CHAR_HEAD (*str));
+ return c;
+}
+
+/* Return the length of the multi-byte form at string STR of length LEN. */
+int
+multibyte_form_length (str, len)
+ unsigned char *str;
+ int len;
+{
+ int charset;
+ unsigned char c1, c2;
+ register int c;
+
+ if (SPLIT_STRING (str, len, charset, c1, c2) == CHARSET_ASCII)
+ return 1;
+
+ return (charset == CHARSET_COMPOSITION
+ ? cmpchar_table[(c1 << 7) | c2]->len
+ : BYTES_BY_CHAR_HEAD (*str));
+}
+
+/* Check if string STR of length LEN contains valid multi-byte form of
+ a character. If valid, charset and position codes of the character
+ is set at *CHARSET, *C1, and *C2, and return 0. If not valid,
+ return -1. This should be used only in the macro SPLIT_STRING
+ which checks range of STR in advance. */
+
+split_non_ascii_string (str, len, charset, c1, c2)
+ register unsigned char *str, *c1, *c2;
+ register int len, *charset;
+{
+ register unsigned int cs = *str++;
+
+ if (cs == LEADING_CODE_COMPOSITION)
+ {
+ int cmpchar_id = str_cmpchar_id (str - 1, len);
+
+ if (cmpchar_id < 0)
+ return -1;
+ *charset = cs, *c1 = cmpchar_id >> 7, *c2 = cmpchar_id & 0x7F;
+ }
+ else if ((cs < LEADING_CODE_PRIVATE_11 || (cs = *str++) >= 0xA0)
+ && CHARSET_DEFINED_P (cs))
+ {
+ *charset = cs;
+ if (*str < 0xA0)
+ return -1;
+ *c1 = (*str++) & 0x7F;
+ if (CHARSET_DIMENSION (cs) == 2)
+ {
+ if (*str < 0xA0)
+ return -1;
+ *c2 = (*str++) & 0x7F;
+ }
+ }
+ else
+ return -1;
+ return 0;
+}
+
+/* Update the table Vcharset_table with the given arguments (see the
+ document of `define-charset' for the meaning of each argument).
+ Several other table contents are also updated. The caller should
+ check the validity of CHARSET-ID and the remaining arguments in
+ advance. */
+
+void
+update_charset_table (charset_id, dimension, chars, width, direction,
+ iso_final_char, iso_graphic_plane,
+ short_name, long_name, description)
+ Lisp_Object charset_id, dimension, chars, width, direction;
+ Lisp_Object iso_final_char, iso_graphic_plane;
+ Lisp_Object short_name, long_name, description;
+{
+ int charset = XINT (charset_id);
+ int bytes;
+ unsigned char leading_code_base, leading_code_ext;
+
+ if (NILP (Faref (Vcharset_table, charset_id)))
+ Faset (Vcharset_table, charset_id,
+ Fmake_vector (make_number (CHARSET_MAX_IDX), Qnil));
+
+ /* Get byte length of multibyte form, base leading-code, and
+ extended leading-code of the charset. See the comment under the
+ title "GENERAL NOTE on CHARACTER SET (CHARSET)" in charset.h. */
+ bytes = XINT (dimension);
+ if (charset < MIN_CHARSET_PRIVATE_DIMENSION1)
+ {
+ /* Official charset, it doesn't have an extended leading-code. */
+ if (charset != CHARSET_ASCII)
+ bytes += 1; /* For a base leading-code. */
+ leading_code_base = charset;
+ leading_code_ext = 0;
+ }
+ else
+ {
+ /* Private charset. */
+ bytes += 2; /* For base and extended leading-codes. */
+ leading_code_base
+ = (charset < LEADING_CODE_EXT_12
+ ? LEADING_CODE_PRIVATE_11
+ : (charset < LEADING_CODE_EXT_21
+ ? LEADING_CODE_PRIVATE_12
+ : (charset < LEADING_CODE_EXT_22
+ ? LEADING_CODE_PRIVATE_21
+ : LEADING_CODE_PRIVATE_22)));
+ leading_code_ext = charset;
+ }
+
+ CHARSET_TABLE_INFO (charset, CHARSET_ID_IDX) = charset_id;
+ CHARSET_TABLE_INFO (charset, CHARSET_BYTES_IDX) = make_number (bytes);
+ CHARSET_TABLE_INFO (charset, CHARSET_DIMENSION_IDX) = dimension;
+ CHARSET_TABLE_INFO (charset, CHARSET_CHARS_IDX) = chars;
+ CHARSET_TABLE_INFO (charset, CHARSET_WIDTH_IDX) = width;
+ CHARSET_TABLE_INFO (charset, CHARSET_DIRECTION_IDX) = direction;
+ CHARSET_TABLE_INFO (charset, CHARSET_LEADING_CODE_BASE_IDX)
+ = make_number (leading_code_base);
+ CHARSET_TABLE_INFO (charset, CHARSET_LEADING_CODE_EXT_IDX)
+ = make_number (leading_code_ext);
+ CHARSET_TABLE_INFO (charset, CHARSET_ISO_FINAL_CHAR_IDX) = iso_final_char;
+ CHARSET_TABLE_INFO (charset, CHARSET_ISO_GRAPHIC_PLANE_IDX)
+ = iso_graphic_plane;
+ CHARSET_TABLE_INFO (charset, CHARSET_SHORT_NAME_IDX) = short_name;
+ CHARSET_TABLE_INFO (charset, CHARSET_LONG_NAME_IDX) = long_name;
+ CHARSET_TABLE_INFO (charset, CHARSET_DESCRIPTION_IDX) = description;
+ CHARSET_TABLE_INFO (charset, CHARSET_PLIST_IDX) = Qnil;
+
+ {
+ /* If we have already defined a charset which has the same
+ DIMENSION, CHARS and ISO-FINAL-CHAR but the different
+ DIRECTION, we must update the entry REVERSE-CHARSET of both
+ charsets. If there's no such charset, the value of the entry
+ is set to nil. */
+ int i;
+
+ for (i = 0; i < MAX_CHARSET; i++)
+ if (!NILP (CHARSET_TABLE_ENTRY (i)))
+ {
+ if (CHARSET_DIMENSION (i) == XINT (dimension)
+ && CHARSET_CHARS (i) == XINT (chars)
+ && CHARSET_ISO_FINAL_CHAR (i) == XINT (iso_final_char)
+ && CHARSET_DIRECTION (i) != XINT (direction))
+ {
+ CHARSET_TABLE_INFO (charset, CHARSET_REVERSE_CHARSET_IDX)
+ = make_number (i);
+ CHARSET_TABLE_INFO (i, CHARSET_REVERSE_CHARSET_IDX) = charset_id;
+ break;
+ }
+ }
+ if (i >= MAX_CHARSET)
+ /* No such a charset. */
+ CHARSET_TABLE_INFO (charset, CHARSET_REVERSE_CHARSET_IDX)
+ = make_number (-1);
+ }
+
+ if (charset != CHARSET_ASCII
+ && charset < MIN_CHARSET_PRIVATE_DIMENSION1)
+ {
+ /* Update tables bytes_by_char_head and width_by_char_head. */
+ bytes_by_char_head[leading_code_base] = bytes;
+ width_by_char_head[leading_code_base] = XINT (width);
+
+ /* Update table emacs_code_class. */
+ emacs_code_class[charset] = (bytes == 2
+ ? EMACS_leading_code_2
+ : (bytes == 3
+ ? EMACS_leading_code_3
+ : EMACS_leading_code_4));
+ }
+
+ /* Update table iso_charset_table. */
+ if (ISO_CHARSET_TABLE (dimension, chars, iso_final_char) < 0)
+ ISO_CHARSET_TABLE (dimension, chars, iso_final_char) = charset;
+}
+
+#ifdef emacs
+
+/* Return charset id of CHARSET_SYMBOL, or return -1 if CHARSET_SYMBOL
+ is invalid. */
+int
+get_charset_id (charset_symbol)
+ Lisp_Object charset_symbol;
+{
+ Lisp_Object val;
+ int charset;
+
+ return ((SYMBOLP (charset_symbol)
+ && (val = Fget (charset_symbol, Qcharset), VECTORP (val))
+ && (charset = XINT (XVECTOR (val)->contents[CHARSET_ID_IDX]),
+ CHARSET_VALID_P (charset)))
+ ? charset : -1);
+}
+
+/* Return an identification number for a new private charset of
+ DIMENSION and WIDTH. If there's no more room for the new charset,
+ return 0. */
+Lisp_Object
+get_new_private_charset_id (dimension, width)
+ int dimension, width;
+{
+ int charset, from, to;
+
+ if (dimension == 1)
+ {
+ if (width == 1)
+ from = LEADING_CODE_EXT_11, to = LEADING_CODE_EXT_12;
+ else
+ from = LEADING_CODE_EXT_12, to = LEADING_CODE_EXT_21;
+ }
+ else
+ {
+ if (width == 1)
+ from = LEADING_CODE_EXT_21, to = LEADING_CODE_EXT_22;
+ else
+ from = LEADING_CODE_EXT_22, to = LEADING_CODE_EXT_MAX - 1;
+ }
+
+ for (charset = from; charset < to; charset++)
+ if (!CHARSET_DEFINED_P (charset)) break;
+
+ return make_number (charset < to ? charset : 0);
+}
+
+DEFUN ("define-charset", Fdefine_charset, Sdefine_charset, 3, 3, 0,
+ "Define CHARSET-ID as the identification number of CHARSET with INFO-VECTOR.\n\
+If CHARSET-ID is nil, it is set automatically, which means CHARSET is\n\
+ treated as a private charset.\n\
+INFO-VECTOR is a vector of the format:\n\
+ [DIMENSION CHARS WIDTH DIRECTION ISO-FINAL-CHAR ISO-GRAPHIC-PLANE\n\
+ SHORT-NAME LONG-NAME DESCRIPTION]\n\
+The meanings of each elements is as follows:\n\
+DIMENSION (integer) is the number of bytes to represent a character: 1 or 2.\n\
+CHARS (integer) is the number of characters in a dimension: 94 or 96.\n\
+WIDTH (integer) is the number of columns a character in the charset\n\
+occupies on the screen: one of 0, 1, and 2.\n\
+\n\
+DIRECTION (integer) is the rendering direction of characters in the\n\
+charset when rendering. If 0, render from right to left, else\n\
+render from left to right.\n\
+\n\
+ISO-FINAL-CHAR (character) is the final character of the\n\
+corresponding ISO 2022 charset.\n\
+\n\
+ISO-GRAPHIC-PLANE (integer) is the graphic plane to be invoked\n\
+while encoding to variants of ISO 2022 coding system, one of the\n\
+following: 0/graphic-plane-left(GL), 1/graphic-plane-right(GR).\n\
+\n\
+SHORT-NAME (string) is the short name to refer to the charset.\n\
+\n\
+LONG-NAME (string) is the long name to refer to the charset.\n\
+\n\
+DESCRIPTION (string) is the description string of the charset.")
+ (charset_id, charset_symbol, info_vector)
+ Lisp_Object charset_id, charset_symbol, info_vector;
+{
+ Lisp_Object *vec;
+
+ if (!NILP (charset_id))
+ CHECK_NUMBER (charset_id, 0);
+ CHECK_SYMBOL (charset_symbol, 1);
+ CHECK_VECTOR (info_vector, 2);
+
+ if (! NILP (charset_id))
+ {
+ if (! CHARSET_VALID_P (XINT (charset_id)))
+ error ("Invalid CHARSET: %d", XINT (charset_id));
+ else if (CHARSET_DEFINED_P (XINT (charset_id)))
+ error ("Already defined charset: %d", XINT (charset_id));
+ }
+
+ vec = XVECTOR (info_vector)->contents;
+ if (XVECTOR (info_vector)->size != 9
+ || !INTEGERP (vec[0]) || !(XINT (vec[0]) == 1 || XINT (vec[0]) == 2)
+ || !INTEGERP (vec[1]) || !(XINT (vec[1]) == 94 || XINT (vec[1]) == 96)
+ || !INTEGERP (vec[2]) || !(XINT (vec[2]) == 1 || XINT (vec[2]) == 2)
+ || !INTEGERP (vec[3]) || !(XINT (vec[3]) == 0 || XINT (vec[3]) == 1)
+ || !INTEGERP (vec[4]) || !(XINT (vec[4]) >= '0' && XINT (vec[4]) <= '~')
+ || !INTEGERP (vec[5]) || !(XINT (vec[5]) == 0 || XINT (vec[5]) == 1)
+ || !STRINGP (vec[6])
+ || !STRINGP (vec[7])
+ || !STRINGP (vec[8]))
+ error ("Invalid info-vector argument for defining charset %s",
+ XSYMBOL (charset_symbol)->name->data);
+
+ if (NILP (charset_id))
+ {
+ charset_id = get_new_private_charset_id (XINT (vec[0]), XINT (vec[2]));
+ if (XINT (charset_id) == 0)
+ error ("There's no room for a new private charset %s",
+ XSYMBOL (charset_symbol)->name->data);
+ }
+
+ update_charset_table (charset_id, vec[0], vec[1], vec[2], vec[3],
+ vec[4], vec[5], vec[6], vec[7], vec[8]);
+ Fput (charset_symbol, Qcharset, Faref (Vcharset_table, charset_id));
+ CHARSET_SYMBOL (XINT (charset_id)) = charset_symbol;
+ Vcharset_list = Fcons (charset_symbol, Vcharset_list);
+ return Qnil;
+}
+
+DEFUN ("declare-equiv-charset", Fdeclare_equiv_charset, Sdeclare_equiv_charset,
+ 4, 4, 0,
+ "Declare a charset of DIMENSION, CHARS, FINAL-CHAR is the same as CHARSET.\n\
+CHARSET should be defined by `defined-charset' in advance.")
+ (dimension, chars, final_char, charset_symbol)
+ Lisp_Object dimension, chars, final_char, charset_symbol;
+{
+ int charset;
+
+ CHECK_NUMBER (dimension, 0);
+ CHECK_NUMBER (chars, 1);
+ CHECK_NUMBER (final_char, 2);
+ CHECK_SYMBOL (charset_symbol, 3);
+
+ if (XINT (dimension) != 1 && XINT (dimension) != 2)
+ error ("Invalid DIMENSION %d, it should be 1 or 2", XINT (dimension));
+ if (XINT (chars) != 94 && XINT (chars) != 96)
+ error ("Invalid CHARS %d, it should be 94 or 96", XINT (chars));
+ if (XINT (final_char) < '0' || XFASTINT (final_char) > '~')
+ error ("Invalid FINAL-CHAR %c, it should be `0'..`~'", XINT (chars));
+ if ((charset = get_charset_id (charset_symbol)) < 0)
+ error ("Invalid charset %s", XSYMBOL (charset_symbol)->name->data);
+
+ ISO_CHARSET_TABLE (dimension, chars, final_char) = charset;
+ return Qnil;
+}
+
+/* Return number of different charsets in STR of length LEN. In
+ addition, for each found charset N, CHARSETS[N] is set 1. The
+ caller should allocate CHARSETS (MAX_CHARSET bytes) in advance. */
+
+int
+find_charset_in_str (str, len, charsets)
+ unsigned char *str, *charsets;
+ int len;
+{
+ int num = 0;
+
+ while (len > 0)
+ {
+ int bytes = BYTES_BY_CHAR_HEAD (*str);
+ int charset = CHARSET_AT (str);
+
+ if (!charsets[charset])
+ {
+ charsets[charset] = 1;
+ num += 1;
+ }
+ str += bytes;
+ len -= bytes;
+ }
+ return num;
+}
+
+DEFUN ("find-charset-region", Ffind_charset_region, Sfind_charset_region,
+ 2, 2, 0,
+ "Return a list of charsets in the region between BEG and END.\n\
+BEG and END are buffer positions.")
+ (beg, end)
+ Lisp_Object beg, end;
+{
+ char charsets[MAX_CHARSET];
+ int from, to, stop, i;
+ Lisp_Object val;
+
+ validate_region (&beg, &end);
+ from = XFASTINT (beg);
+ stop = to = XFASTINT (end);
+ if (from < GPT && GPT < to)
+ stop = GPT;
+ bzero (charsets, MAX_CHARSET);
+ while (1)
+ {
+ find_charset_in_str (POS_ADDR (from), stop - from, charsets);
+ if (stop < to)
+ from = stop, stop = to;
+ else
+ break;
+ }
+ val = Qnil;
+ for (i = MAX_CHARSET - 1; i >= 0; i--)
+ if (charsets[i])
+ val = Fcons (CHARSET_SYMBOL (i), val);
+ return val;
+}
+
+DEFUN ("find-charset-string", Ffind_charset_string, Sfind_charset_string,
+ 1, 1, 0,
+ "Return a list of charsets in STR.")
+ (str)
+ Lisp_Object str;
+{
+ char charsets[MAX_CHARSET];
+ int i;
+ Lisp_Object val;
+
+ CHECK_STRING (str, 0);
+ bzero (charsets, MAX_CHARSET);
+ find_charset_in_str (XSTRING (str)->data, XSTRING (str)->size, charsets);
+ val = Qnil;
+ for (i = MAX_CHARSET - 1; i >= 0; i--)
+ if (charsets[i])
+ val = Fcons (CHARSET_SYMBOL (i), val);
+ return val;
+}
+\f
+DEFUN ("make-char-internal", Fmake_char_internal, Smake_char_internal, 1, 3, 0,
+ "Return a character of CHARSET and position-codes CODE1 and CODE2.\n\
+CODE1 and CODE2 are optional, but if you don't supply\n\
+ sufficient position-codes, return a generic character which stands for\n\
+all characters or group of characters in the character sets.\n\
+A generic character can be an argument of `modify-syntax-entry' and\n\
+`modify-category-entry'.")
+ (charset, code1, code2)
+ Lisp_Object charset, code1, code2;
+{
+ CHECK_NUMBER (charset, 0);
+
+ if (NILP (code1))
+ XSETFASTINT (code1, 0);
+ else
+ CHECK_NUMBER (code1, 1);
+ if (NILP (code2))
+ XSETFASTINT (code2, 0);
+ else
+ CHECK_NUMBER (code2, 2);
+
+ if (!CHARSET_DEFINED_P (XINT (charset)))
+ error ("Invalid charset: %d", XINT (charset));
+
+ return make_number (MAKE_CHAR (XINT (charset), XINT (code1), XINT (code2)));
+}
+
+DEFUN ("split-char", Fsplit_char, Ssplit_char, 1, 1, 0,
+ "Return list of charset and one or two position-codes of CHAR.")
+ (ch)
+ Lisp_Object ch;
+{
+ Lisp_Object val;
+ int charset;
+ unsigned char c1, c2;
+
+ CHECK_NUMBER (ch, 0);
+ SPLIT_CHAR (XFASTINT (ch), charset, c1, c2);
+ return ((charset == CHARSET_COMPOSITION || CHARSET_DIMENSION (charset) == 2)
+ ? Fcons (CHARSET_SYMBOL (charset),
+ Fcons (make_number (c1), Fcons (make_number (c2), Qnil)))
+ : Fcons (CHARSET_SYMBOL (charset), Fcons (make_number (c1), Qnil)));
+}
+
+DEFUN ("char-charset", Fchar_charset, Schar_charset, 1, 1, 0,
+ "Return charset of CHAR.")
+ (ch)
+ Lisp_Object ch;
+{
+ CHECK_NUMBER (ch, 0);
+
+ return CHARSET_SYMBOL (CHAR_CHARSET (XINT (ch)));
+}
+
+DEFUN ("iso-charset", Fiso_charset, Siso_charset, 3, 3, 0,
+ "Return charset of ISO's specification DIMENSION, CHARS, and FINAL-CHAR.")
+ (dimension, chars, final_char)
+ Lisp_Object dimension, chars, final_char;
+{
+ int charset;
+
+ CHECK_NUMBER (dimension, 0);
+ CHECK_NUMBER (chars, 1);
+ CHECK_NUMBER (final_char, 2);
+
+ if ((charset = ISO_CHARSET_TABLE (dimension, chars, final_char)) < 0)
+ return Qnil;
+ return CHARSET_SYMBOL (charset);
+}
+
+DEFUN ("char-bytes", Fchar_bytes, Schar_bytes, 1, 1, 0,
+ "Return byte length of multi-byte form of CHAR.")
+ (ch)
+ Lisp_Object ch;
+{
+ Lisp_Object val;
+ int bytes;
+
+ CHECK_NUMBER (ch, 0);
+ if (COMPOSITE_CHAR_P (XFASTINT (ch)))
+ {
+ unsigned int id = COMPOSITE_CHAR_ID (XFASTINT (ch));
+
+ bytes = (id < n_cmpchars ? cmpchar_table[id]->len : 1);
+ }
+ else
+ {
+ int charset = CHAR_CHARSET (XFASTINT (ch));
+
+ bytes = CHARSET_DEFINED_P (charset) ? CHARSET_BYTES (charset) : 1;
+ }
+
+ XSETFASTINT (val, bytes);
+ return val;
+}
+
+/* Return the width of character of which multi-byte form starts with
+ C. The width is measured by how many columns occupied on the
+ screen when displayed in the current buffer. */
+
+#define ONE_BYTE_CHAR_WIDTH(c) \
+ (c < 0x20 \
+ ? (c == '\t' \
+ ? current_buffer->tab_width \
+ : (c == '\n' ? 0 : (NILP (current_buffer->ctl_arrow) ? 4 : 2))) \
+ : (c < 0x7f \
+ ? 1 \
+ : (c == 0x7F \
+ ? (NILP (current_buffer->ctl_arrow) ? 4 : 2) \
+ : ((! NILP (current_buffer->enable_multibyte_characters) \
+ && BASE_LEADING_CODE_P (c)) \
+ ? WIDTH_BY_CHAR_HEAD (c) \
+ : 4)))) \
+
+
+DEFUN ("char-width", Fchar_width, Schar_width, 1, 1, 0,
+ "Return width of CHAR when displayed in the current buffer.\n\
+The width is measured by how many columns it occupies on the screen.")
+ (ch)
+ Lisp_Object ch;
+{
+ Lisp_Object val;
+ int c;
+
+ CHECK_NUMBER (ch, 0);
+
+ c = XFASTINT (ch);
+ if (SINGLE_BYTE_CHAR_P (c))
+ XSETFASTINT (val, ONE_BYTE_CHAR_WIDTH (c));
+ else if (COMPOSITE_CHAR_P (c))
+ {
+ int id = COMPOSITE_CHAR_ID (XFASTINT (ch));
+ XSETFASTINT (val, (id < n_cmpchars ? cmpchar_table[id]->width : 0));
+ }
+ else
+ {
+ int charset = CHAR_CHARSET (c);
+
+ XSETFASTINT (val, CHARSET_WIDTH (charset));
+ }
+ return val;
+}
+
+/* Return width of string STR of length LEN when displayed in the
+ current buffer. The width is measured by how many columns it
+ occupies on the screen. */
+int
+strwidth (str, len)
+ unsigned char *str;
+ int len;
+{
+ unsigned char *endp = str + len;
+ int width = 0;
+
+ while (str < endp) {
+ if (*str == LEADING_CODE_COMPOSITION)
+ {
+ int id = str_cmpchar_id (str, endp - str);
+
+ if (id < 0)
+ {
+ width += 4;
+ str++;
+ }
+ else
+ {
+ width += cmpchar_table[id]->width;
+ str += cmpchar_table[id]->len;
+ }
+ }
+ else
+ {
+ width += ONE_BYTE_CHAR_WIDTH (*str);
+ str += BYTES_BY_CHAR_HEAD (*str);
+ }
+ }
+ return width;
+}
+
+DEFUN ("string-width", Fstring_width, Sstring_width, 1, 1, 0,
+ "Return width of STRING when displayed in the current buffer.\n\
+Width is measured by how many columns it occupies on the screen.\n\
+When calculating width of a multi-byte character in STRING,\n\
+ only the base leading-code is considered and the validity of\n\
+ the following bytes are not checked.")
+ (str)
+ Lisp_Object str;
+{
+ Lisp_Object val;
+
+ CHECK_STRING (str, 0);
+ XSETFASTINT (val, strwidth (XSTRING (str)->data, XSTRING (str)->size));
+ return val;
+}
+
+DEFUN ("char-direction", Fchar_direction, Schar_direction, 1, 1, 0,
+ "Return the direction of CHAR.\n\
+The returned value is 0 for left-to-right and 1 for right-to-left.")
+ (ch)
+ Lisp_Object ch;
+{
+ int charset;
+
+ CHECK_NUMBER (ch, 0);
+ charset = CHAR_CHARSET (XFASTINT (ch));
+ if (!CHARSET_DEFINED_P (charset))
+ error ("Invalid character: %d", XINT (ch));
+ return CHARSET_TABLE_INFO (charset, CHARSET_DIRECTION_IDX);
+}
+
+DEFUN ("chars-in-string", Fchars_in_string, Schars_in_string, 1, 1, 0,
+ "Return number of characters in STRING.")
+ (str)
+ Lisp_Object str;
+{
+ Lisp_Object val;
+ unsigned char *p, *endp;
+ int chars;
+
+ CHECK_STRING (str, 0);
+
+ p = XSTRING (str)->data; endp = p + XSTRING (str)->size;
+ chars = 0;
+ while (p < endp)
+ {
+ if (*p == LEADING_CODE_COMPOSITION)
+ {
+ p++;
+ while (p < endp && ! CHAR_HEAD_P (p)) p++;
+ }
+ else
+ p += BYTES_BY_CHAR_HEAD (*p);
+ chars++;
+ }
+
+ XSETFASTINT (val, chars);
+ return val;
+}
+
+DEFUN ("char-boundary-p", Fchar_boundary_p, Schar_boundary_p, 1, 1, 0,
+ "Return non-nil value if POS is at character boundary of multibyte form.\n\
+The return value is:\n\
+ 0 if POS is at an ASCII character or at the end of range,\n\
+ 1 if POS is at a head of 2-byte length multi-byte form,\n\
+ 2 if POS is at a head of 3-byte length multi-byte form,\n\
+ 3 if POS is at a head of 4-byte length multi-byte form,\n\
+ 4 if POS is at a head of multi-byte form of a composite character.\n\
+If POS is out of range or not at character boundary, return NIL.")
+ (pos)
+ Lisp_Object pos;
+{
+ Lisp_Object val;
+ int n;
+
+ CHECK_NUMBER_COERCE_MARKER (pos, 0);
+
+ n = XINT (pos);
+ if (n < BEGV || n > ZV)
+ return Qnil;
+
+ if (n == ZV || NILP (current_buffer->enable_multibyte_characters))
+ XSETFASTINT (val, 0);
+ else
+ {
+ unsigned char *p = POS_ADDR (n);
+
+ if (SINGLE_BYTE_CHAR_P (*p))
+ XSETFASTINT (val, 0);
+ else if (*p == LEADING_CODE_COMPOSITION)
+ XSETFASTINT (val, 4);
+ else if (BYTES_BY_CHAR_HEAD (*p) > 1)
+ XSETFASTINT (val, BYTES_BY_CHAR_HEAD (*p) - 1);
+ else
+ val = Qnil;
+ }
+ return val;
+}
+
+DEFUN ("concat-chars", Fconcat_chars, Sconcat_chars, 1, MANY, 0,
+ "Concatenate all the argument characters and make the result a string.")
+ (nargs, args)
+ int nargs;
+ Lisp_Object *args;
+{
+ int i, n = XINT (nargs);
+ unsigned char *buf
+ = (unsigned char *) malloc (MAX_LENGTH_OF_MULTI_BYTE_FORM * n);
+ unsigned char *p = buf;
+ Lisp_Object val;
+
+ for (i = 0; i < n; i++)
+ {
+ int c, len;
+ unsigned char *str;
+
+ if (!INTEGERP (args[i]))
+ {
+ free (buf);
+ CHECK_NUMBER (args[i], 0);
+ }
+ c = XINT (args[i]);
+ len = CHAR_STRING (c, p, str);
+ if (p != str)
+ /* C is a composite character. */
+ bcopy (str, p, len);
+ p += len;
+ }
+
+ val = make_string (buf, p - buf);
+ free (buf);
+ return val;
+}
+
+#endif /* emacs */
+\f
+/*** Composite characters staffs ***/
+
+/* Each composite character is identified by CMPCHAR-ID which is
+ assigned when Emacs needs the character code of the composite
+ character (e.g. when displaying it on the screen). See the
+ document "GENERAL NOTE on COMPOSITE CHARACTER" in `charset.h' how a
+ composite character is represented in Emacs. */
+
+/* If `static' is defined, it means that it is defined to null string. */
+#ifndef static
+/* The following function is copied from lread.c. */
+static int
+hash_string (ptr, len)
+ unsigned char *ptr;
+ int len;
+{
+ register unsigned char *p = ptr;
+ register unsigned char *end = p + len;
+ register unsigned char c;
+ register int hash = 0;
+
+ while (p != end)
+ {
+ c = *p++;
+ if (c >= 0140) c -= 40;
+ hash = ((hash<<3) + (hash>>28) + c);
+ }
+ return hash & 07777777777;
+}
+#endif
+
+/* Table of pointers to the structure `cmpchar_info' indexed by
+ CMPCHAR-ID. */
+struct cmpchar_info **cmpchar_table;
+/* The current size of `cmpchar_table'. */
+static int cmpchar_table_size;
+/* Number of the current composite characters. */
+int n_cmpchars;
+
+#define CMPCHAR_HASH_TABLE_SIZE 0xFFF
+
+static int *cmpchar_hash_table[CMPCHAR_HASH_TABLE_SIZE];
+
+/* Each element of `cmpchar_hash_table' is a pointer to an array of
+ integer, where the 1st element is the size of the array, the 2nd
+ element is how many elements are actually used in the array, and
+ the remaining elements are CMPCHAR-IDs of composite characters of
+ the same hash value. */
+#define CMPCHAR_HASH_SIZE(table) table[0]
+#define CMPCHAR_HASH_USED(table) table[1]
+#define CMPCHAR_HASH_CMPCHAR_ID(table, i) table[i]
+
+/* Return CMPCHAR-ID of the composite character in STR of the length
+ LEN. If the composite character has not yet been registered,
+ register it in `cmpchar_table' and assign new CMPCHAR-ID. This
+ is the sole function for assigning CMPCHAR-ID. */
+int
+str_cmpchar_id (str, len)
+ unsigned char *str;
+ int len;
+{
+ int hash_idx, *hashp;
+ unsigned char *buf;
+ int embedded_rule; /* 1 if composition rule is embedded. */
+ int chars; /* number of components. */
+ int i;
+ struct cmpchar_info *cmpcharp;
+
+ if (len < 5)
+ /* Any composite char have at least 3-byte length. */
+ return -1;
+
+ /* The second byte 0xFF means compostion rule is embedded. */
+ embedded_rule = (str[1] == 0xFF);
+
+ /* At first, get the actual length of the composite character. */
+ {
+ unsigned char *p, *endp = str + 1, *lastp = str + len;
+ int bytes;
+
+ while (endp < lastp && ! CHAR_HEAD_P (endp)) endp++;
+ chars = 0;
+ p = str + 1 + embedded_rule;
+ while (p < endp)
+ {
+ /* No need of checking if *P is 0xA0 because
+ BYTES_BY_CHAR_HEAD (0x80) surely returns 2. */
+ p += (bytes = BYTES_BY_CHAR_HEAD (*p - 0x20) + embedded_rule);
+ chars++;
+ }
+ len = (p -= embedded_rule) - str;
+ if (p > endp)
+ len -= - bytes, chars--;
+
+ if (chars < 2 || chars > MAX_COMPONENT_COUNT)
+ /* Invalid number of components. */
+ return -1;
+ }
+ hash_idx = hash_string (str, len) % CMPCHAR_HASH_TABLE_SIZE;
+ hashp = cmpchar_hash_table[hash_idx];
+
+ /* Then, look into the hash table. */
+ if (hashp != NULL)
+ /* Find the correct one among composite characters of the same
+ hash value. */
+ for (i = 2; i < CMPCHAR_HASH_USED (hashp); i++)
+ {
+ cmpcharp = cmpchar_table[CMPCHAR_HASH_CMPCHAR_ID (hashp, i)];
+ if (len == cmpcharp->len
+ && ! bcmp (str, cmpcharp->data, len))
+ return CMPCHAR_HASH_CMPCHAR_ID (hashp, i);
+ }
+
+ /* We have to register the composite character in cmpchar_table. */
+ /* Make the entry in hash table. */
+ if (hashp == NULL)
+ {
+ /* Make a table for 8 composite characters initially. */
+ hashp = (cmpchar_hash_table[hash_idx]
+ = (int *) xmalloc (sizeof (int) * (2 + 8)));
+ CMPCHAR_HASH_SIZE (hashp) = 10;
+ CMPCHAR_HASH_USED (hashp) = 2;
+ }
+ else if (CMPCHAR_HASH_USED (hashp) >= CMPCHAR_HASH_SIZE (hashp))
+ {
+ CMPCHAR_HASH_SIZE (hashp) += 8;
+ hashp = (cmpchar_hash_table[hash_idx]
+ = (int *) xrealloc (hashp,
+ sizeof (int) * CMPCHAR_HASH_SIZE (hashp)));
+ }
+ CMPCHAR_HASH_CMPCHAR_ID (hashp, CMPCHAR_HASH_USED (hashp)) = n_cmpchars;
+ CMPCHAR_HASH_USED (hashp)++;
+
+ /* Set information of the composite character in cmpchar_table. */
+ if (cmpchar_table_size == 0)
+ {
+ /* This is the first composite character to be registered. */
+ cmpchar_table_size = 256;
+ cmpchar_table
+ = (struct cmpchar_info **) xmalloc (sizeof (cmpchar_table[0])
+ * cmpchar_table_size);
+ }
+ else if (cmpchar_table_size <= n_cmpchars)
+ {
+ cmpchar_table_size += 256;
+ cmpchar_table
+ = (struct cmpchar_info **) xrealloc (cmpchar_table,
+ sizeof (cmpchar_table[0])
+ * cmpchar_table_size);
+ }
+
+ cmpcharp = (struct cmpchar_info *) xmalloc (sizeof (struct cmpchar_info));
+
+ cmpcharp->len = len;
+ cmpcharp->data = (unsigned char *) xmalloc (len + 1);
+ bcopy (str, cmpcharp->data, len);
+ cmpcharp->data[len] = 0;
+ cmpcharp->glyph_len = chars;
+ cmpcharp->glyph = (GLYPH *) xmalloc (sizeof (GLYPH) * chars);
+ if (embedded_rule)
+ {
+ cmpcharp->cmp_rule = (unsigned char *) xmalloc (chars);
+ cmpcharp->col_offset = (float *) xmalloc (sizeof (float) * chars);
+ }
+ else
+ {
+ cmpcharp->cmp_rule = NULL;
+ cmpcharp->col_offset = NULL;
+ }
+
+ /* Setup GLYPH data and composition rules (if any) so as not to make
+ them every time on displaying. */
+ {
+ unsigned char *bufp;
+ int width;
+ float leftmost = 0.0, rightmost = 1.0;
+
+ if (embedded_rule)
+ /* At first, col_offset[N] is set to relative to col_offset[0]. */
+ cmpcharp->col_offset[0] = 0;
+
+ for (i = 0, bufp = cmpcharp->data + 1; i < chars; i++)
+ {
+ if (embedded_rule)
+ cmpcharp->cmp_rule[i] = *bufp++;
+
+ if (*bufp == 0xA0) /* This is an ASCII character. */
+ {
+ cmpcharp->glyph[i] = FAST_MAKE_GLYPH ((*++bufp & 0x7F), 0);
+ width = 1;
+ bufp++;
+ }
+ else /* Multibyte character. */
+ {
+ /* Make `bufp' point normal multi-byte form temporally. */
+ *bufp -= 0x20;
+ cmpcharp->glyph[i]
+ = FAST_MAKE_GLYPH (string_to_non_ascii_char (bufp, 4, 0), 0);
+ width = WIDTH_BY_CHAR_HEAD (*bufp);
+ *bufp += 0x20;
+ bufp += BYTES_BY_CHAR_HEAD (*bufp - 0x20);
+ }
+
+ if (embedded_rule && i > 0)
+ {
+ /* Reference points (global_ref and new_ref) are
+ encoded as below:
+
+ 0--1--2 -- ascent
+ | |
+ | |
+ | 4 -+--- center
+ -- 3 5 -- baseline
+ | |
+ 6--7--8 -- descent
+
+ Now, we calculate the column offset of the new glyph
+ from the left edge of the first glyph. This can avoid
+ the same calculation everytime displaying this
+ composite character. */
+
+ /* Reference points of global glyph and new glyph. */
+ int global_ref = (cmpcharp->cmp_rule[i] - 0xA0) / 9;
+ int new_ref = (cmpcharp->cmp_rule[i] - 0xA0) % 9;
+ /* Column offset relative to the first glyph. */
+ float left = (leftmost
+ + (global_ref % 3) * (rightmost - leftmost) / 2.0
+ - (new_ref % 3) * width / 2.0);
+
+ cmpcharp->col_offset[i] = left;
+ if (left < leftmost)
+ leftmost = left;
+ if (left + width > rightmost)
+ rightmost = left + width;
+ }
+ else
+ {
+ if (width > rightmost)
+ rightmost = width;
+ }
+ }
+ if (embedded_rule)
+ {
+ /* Now col_offset[N] are relative to the left edge of the
+ first component. Make them relative to the left edge of
+ overall glyph. */
+ for (i = 0; i < chars; i++)
+ cmpcharp->col_offset[i] -= leftmost;
+ /* Make rightmost holds width of overall glyph. */
+ rightmost -= leftmost;
+ }
+
+ cmpcharp->width = rightmost;
+ if (cmpcharp->width < rightmost)
+ /* To get a ceiling integer value. */
+ cmpcharp->width++;
+ }
+
+ cmpchar_table[n_cmpchars] = cmpcharp;
+
+ return n_cmpchars++;
+}
+
+/* Return the Nth element of the composite character C. */
+int
+cmpchar_component (c, n)
+ unsigned int c, n;
+{
+ int id = COMPOSITE_CHAR_ID (c);
+
+ if (id >= n_cmpchars /* C is not a valid composite character. */
+ || n >= cmpchar_table[id]->glyph_len) /* No such component. */
+ return -1;
+ /* No face data is stored in glyph code. */
+ return ((int) (cmpchar_table[id]->glyph[n]));
+}
+
+DEFUN ("cmpcharp", Fcmpcharp, Scmpcharp, 1, 1, 0,
+ "T if CHAR is a composite character.")
+ (ch)
+ Lisp_Object ch;
+{
+ CHECK_NUMBER (ch, 0);
+ return (COMPOSITE_CHAR_P (XINT (ch)) ? Qt : Qnil);
+}
+
+DEFUN ("composite-char-component", Fcmpchar_component, Scmpchar_component,
+ 2, 2, 0,
+ "Return the IDXth component character of composite character CHARACTER.")
+ (character, idx)
+ Lisp_Object character, idx;
+{
+ int c;
+
+ CHECK_NUMBER (character, 0);
+ CHECK_NUMBER (idx, 1);
+
+ if ((c = cmpchar_component (XINT (character), XINT (idx))) < 0)
+ args_out_of_range (character, idx);
+
+ return make_number (c);
+}
+
+DEFUN ("composite-char-composition-rule", Fcmpchar_cmp_rule, Scmpchar_cmp_rule,
+ 2, 2, 0,
+ "Return the IDXth composition rule embedded in composite character CHARACTER.
+The returned rule is for composing the IDXth component
+on the (IDX-1)th component. If IDX is 0, the returned value is always 255.")
+ (character, idx)
+ Lisp_Object character, idx;
+{
+ int id, i;
+
+ CHECK_NUMBER (character, 0);
+ CHECK_NUMBER (idx, 1);
+
+ id = COMPOSITE_CHAR_ID (XINT (character));
+ if (id < 0 || id >= n_cmpchars)
+ error ("Invalid composite character: %d", XINT (character));
+ i = XINT (idx);
+ if (i > cmpchar_table[id]->glyph_len)
+ args_out_of_range (character, idx);
+
+ return make_number (cmpchar_table[id]->cmp_rule[i]);
+}
+
+DEFUN ("composite-char-composition-rule-p", Fcmpchar_cmp_rule_p,
+ Scmpchar_cmp_rule_p, 1, 1, 0,
+ "Return non-nil if composite character CHARACTER contains a embedded rule.")
+ (character)
+ Lisp_Object character;
+{
+ int id;
+
+ CHECK_NUMBER (character, 0);
+ id = COMPOSITE_CHAR_ID (XINT (character));
+ if (id < 0 || id >= n_cmpchars)
+ error ("Invalid composite character: %d", XINT (character));
+
+ return (cmpchar_table[id]->cmp_rule ? Qt : Qnil);
+}
+
+DEFUN ("composite-char-component-count", Fcmpchar_cmp_count,
+ Scmpchar_cmp_count, 1, 1, 0,
+ "Return number of compoents of composite character CHARACTER.")
+ (character)
+ Lisp_Object character;
+{
+ int id;
+
+ CHECK_NUMBER (character, 0);
+ id = COMPOSITE_CHAR_ID (XINT (character));
+ if (id < 0 || id >= n_cmpchars)
+ error ("Invalid composite character: %d", XINT (character));
+
+ return (make_number (cmpchar_table[id]->glyph_len));
+}
+
+DEFUN ("compose-string", Fcompose_string, Scompose_string,
+ 1, 1, 0,
+ "Return one char string composed from all characters in STRING.")
+ (str)
+ Lisp_Object str;
+{
+ unsigned char buf[MAX_LENGTH_OF_MULTI_BYTE_FORM], *p, *pend, *ptemp;
+ int len, i;
+
+ CHECK_STRING (str, 0);
+
+ buf[0] = LEADING_CODE_COMPOSITION;
+ p = XSTRING (str)->data;
+ pend = p + XSTRING (str)->size;
+ i = 1;
+ while (p < pend)
+ {
+ if (*p < 0x20 || *p == 127) /* control code */
+ error ("Invalid component character: %d", *p);
+ else if (*p < 0x80) /* ASCII */
+ {
+ if (i + 2 >= MAX_LENGTH_OF_MULTI_BYTE_FORM)
+ error ("Too long string to be composed: %s", XSTRING (str)->data);
+ /* Prepend an ASCII charset indicator 0xA0, set MSB of the
+ code itself. */
+ buf[i++] = 0xA0;
+ buf[i++] = *p++ + 0x80;
+ }
+ else if (*p == LEADING_CODE_COMPOSITION) /* composite char */
+ {
+ /* Already composed. Eliminate the heading
+ LEADING_CODE_COMPOSITION, keep the remaining bytes
+ unchanged. */
+ p++;
+ ptemp = p;
+ while (! CHAR_HEAD_P (p)) p++;
+ if (i + (p - ptemp) >= MAX_LENGTH_OF_MULTI_BYTE_FORM)
+ error ("Too long string to be composed: %s", XSTRING (str)->data);
+ bcopy (ptemp, buf + i, p - ptemp);
+ i += p - ptemp;
+ }
+ else /* multibyte char */
+ {
+ /* Add 0x20 to the base leading-code, keep the remaining
+ bytes unchanged. */
+ len = BYTES_BY_CHAR_HEAD (*p);
+ if (i + len >= MAX_LENGTH_OF_MULTI_BYTE_FORM)
+ error ("Too long string to be composed: %s", XSTRING (str)->data);
+ bcopy (p, buf + i, len);
+ buf[i] += 0x20;
+ p += len, i += len;
+ }
+ }
+
+ if (i < 5)
+ /* STR contains only one character, which can't be composed. */
+ error ("Too short string to be composed: %s", XSTRING (str)->data);
+
+ return make_string (buf, i);
+}
+
+\f
+charset_id_internal (charset_name)
+ char *charset_name;
+{
+ Lisp_Object val = Fget (intern (charset_name), Qcharset);
+
+ if (!VECTORP (val))
+ error ("Charset %s is not defined", charset_name);
+
+ return (XINT (XVECTOR (val)->contents[0]));
+}
+
+DEFUN ("setup-special-charsets", Fsetup_special_charsets,
+ Ssetup_special_charsets, 0, 0, 0, "Internal use only.")
+ ()
+{
+ charset_latin_iso8859_1 = charset_id_internal ("latin-iso8859-1");
+ charset_jisx0208_1978 = charset_id_internal ("japanese-jisx0208-1978");
+ charset_jisx0208 = charset_id_internal ("japanese-jisx0208");
+ charset_katakana_jisx0201 = charset_id_internal ("katakana-jisx0201");
+ charset_latin_jisx0201 = charset_id_internal ("latin-jisx0201");
+ charset_big5_1 = charset_id_internal ("chinese-big5-1");
+ charset_big5_2 = charset_id_internal ("chinese-big5-2");
+ return Qnil;
+}
+
+init_charset_once ()
+{
+ int i, j, k;
+
+ staticpro (&Vcharset_table);
+ staticpro (&Vcharset_symbol_table);
+
+ /* This has to be done here, before we call Fmake_char_table. */
+ Qcharset_table = intern ("charset-table");
+ staticpro (&Qcharset_table);
+
+ /* Intern this now in case it isn't already done.
+ Setting this variable twice is harmless.
+ But don't staticpro it here--that is done in alloc.c. */
+ Qchar_table_extra_slots = intern ("char-table-extra-slots");
+
+ /* Now we are ready to set up this property, so we can
+ create the charset table. */
+ Fput (Qcharset_table, Qchar_table_extra_slots, make_number (0));
+ Vcharset_table = Fmake_char_table (Qcharset_table, Qnil);
+
+ Vcharset_symbol_table = Fmake_vector (make_number (MAX_CHARSET), Qnil);
+
+ /* Setup tables. */
+ for (i = 0; i < 2; i++)
+ for (j = 0; j < 2; j++)
+ for (k = 0; k < 128; k++)
+ iso_charset_table [i][j][k] = -1;
+
+ bzero (cmpchar_hash_table, sizeof cmpchar_hash_table);
+ cmpchar_table_size = n_cmpchars = 0;
+
+ for (i = 0; i < 256; i++)
+ BYTES_BY_CHAR_HEAD (i) = 1;
+ BYTES_BY_CHAR_HEAD (LEADING_CODE_PRIVATE_11) = 3;
+ BYTES_BY_CHAR_HEAD (LEADING_CODE_PRIVATE_12) = 3;
+ BYTES_BY_CHAR_HEAD (LEADING_CODE_PRIVATE_21) = 4;
+ BYTES_BY_CHAR_HEAD (LEADING_CODE_PRIVATE_22) = 4;
+ /* The following doesn't reflect the actual bytes, but just to tell
+ that it is a start of a multibyte character. */
+ BYTES_BY_CHAR_HEAD (LEADING_CODE_COMPOSITION) = 2;
+
+ for (i = 0; i < 128; i++)
+ WIDTH_BY_CHAR_HEAD (i) = 1;
+ for (; i < 256; i++)
+ WIDTH_BY_CHAR_HEAD (i) = 4;
+ WIDTH_BY_CHAR_HEAD (LEADING_CODE_PRIVATE_11) = 1;
+ WIDTH_BY_CHAR_HEAD (LEADING_CODE_PRIVATE_12) = 2;
+ WIDTH_BY_CHAR_HEAD (LEADING_CODE_PRIVATE_21) = 1;
+ WIDTH_BY_CHAR_HEAD (LEADING_CODE_PRIVATE_22) = 2;
+}
+
+#ifdef emacs
+
+syms_of_charset ()
+{
+ Qascii = intern ("ascii");
+ staticpro (&Qascii);
+
+ Qcharset = intern ("charset");
+ staticpro (&Qcharset);
+
+ /* Define ASCII charset now. */
+ update_charset_table (make_number (CHARSET_ASCII),
+ make_number (1), make_number (94),
+ make_number (1),
+ make_number (0),
+ make_number ('B'),
+ make_number (0),
+ build_string ("ASCII"),
+ build_string ("ASCII"),
+ build_string ("ASCII (ISO646 IRV)"));
+ CHARSET_SYMBOL (CHARSET_ASCII) = Qascii;
+ Fput (Qascii, Qcharset, CHARSET_TABLE_ENTRY (CHARSET_ASCII));
+
+ Qcomposition = intern ("composition");
+ staticpro (&Qcomposition);
+ CHARSET_SYMBOL (CHARSET_COMPOSITION) = Qcomposition;
+
+ defsubr (&Sdefine_charset);
+ defsubr (&Sdeclare_equiv_charset);
+ defsubr (&Sfind_charset_region);
+ defsubr (&Sfind_charset_string);
+ defsubr (&Smake_char_internal);
+ defsubr (&Ssplit_char);
+ defsubr (&Schar_charset);
+ defsubr (&Siso_charset);
+ defsubr (&Schar_bytes);
+ defsubr (&Schar_width);
+ defsubr (&Sstring_width);
+ defsubr (&Schar_direction);
+ defsubr (&Schars_in_string);
+ defsubr (&Schar_boundary_p);
+ defsubr (&Sconcat_chars);
+ defsubr (&Scmpcharp);
+ defsubr (&Scmpchar_component);
+ defsubr (&Scmpchar_cmp_rule);
+ defsubr (&Scmpchar_cmp_rule_p);
+ defsubr (&Scmpchar_cmp_count);
+ defsubr (&Scompose_string);
+ defsubr (&Ssetup_special_charsets);
+
+ DEFVAR_LISP ("charset-list", &Vcharset_list,
+ "List of charsets ever defined.");
+ Vcharset_list = Fcons (Qascii, Qnil);
+
+ DEFVAR_INT ("leading-code-composition", &leading_code_composition,
+ "Leading-code of composite characters.");
+ leading_code_composition = LEADING_CODE_COMPOSITION;
+
+ DEFVAR_INT ("leading-code-private-11", &leading_code_private_11,
+ "Leading-code of private TYPE9N charset of column-width 1.");
+ leading_code_private_11 = LEADING_CODE_PRIVATE_11;
+
+ DEFVAR_INT ("leading-code-private-12", &leading_code_private_12,
+ "Leading-code of private TYPE9N charset of column-width 2.");
+ leading_code_private_12 = LEADING_CODE_PRIVATE_12;
+
+ DEFVAR_INT ("leading-code-private-21", &leading_code_private_21,
+ "Leading-code of private TYPE9Nx9N charset of column-width 1.");
+ leading_code_private_21 = LEADING_CODE_PRIVATE_21;
+
+ DEFVAR_INT ("leading-code-private-22", &leading_code_private_22,
+ "Leading-code of private TYPE9Nx9N charset of column-width 2.");
+ leading_code_private_22 = LEADING_CODE_PRIVATE_22;
+}
+
+#endif /* emacs */
--- /dev/null
+/* Header for multilingual character handler.
+ Ver.1.0
+
+ Copyright (C) 1995 Free Software Foundation, Inc.
+ Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#ifndef _CHARSET_H
+#define _CHARSET_H
+
+/*** GENERAL NOTE on CHARACTER SET (CHARSET) ***
+
+ A character set ("charset" hereafter) is a meaningful collection
+ (i.e. language, culture, functionality, etc) of characters. Emacs
+ handles multiple charsets at once. Each charset corresponds to one
+ of ISO charsets (except for a special charset for composition
+ characters). Emacs identifies a charset by a unique identification
+ number, whereas ISO identifies a charset by a triplet of DIMENSION,
+ CHARS and FINAL-CHAR. So, hereafter, just saying "charset" means an
+ identification number (integer value).
+
+ The value range of charset is 0x00, 0x80..0xFE. There are four
+ kinds of charset depending on DIMENSION (1 or 2) and CHARS (94 or
+ 96). For instance, a charset of DIMENSION2_CHARS94 contains 94x94
+
+
+ Within Emacs Lisp, a charset is treated as a symbol which has a
+ property `charset'. The property value is a vector containing
+ various information about the charset. For readability of C codes,
+ we use the following convention on C variable names:
+ charset_symbol: Emacs Lisp symbol of a charset
+ charset_id: Emacs Lisp integer of an identification number of a charset
+ charset: C integer of an identification number of a charset
+
+ Each charset (except for ASCII) is assigned a base leading-code
+ (range 0x80..0x9D). In addition, a charset of greater than 0xA0
+ (whose base leading-code is 0x9A..0x9D) is assigned an extended
+ leading-code (range 0xA0..0xFE). In this case, each base
+ leading-code specify the allowable range of extended leading-code as
+ shown in the table below. A leading-code is used to represent a
+ character in Emacs' buffer and string.
+
+ We call a charset which has extended leading-code as "private
+ charset" because those are mainly for a charset which is not
+ registered by ISO. On the contrary, we call a charset which does
+ not have extended leading-code as "official charset".
+
+ ---------------------------------------------------------------------------
+ charset dimension base leading-code extended leading-code
+ ---------------------------------------------------------------------------
+ 0x00 official dim1 -- none -- -- none --
+ (ASCII)
+ 0x01..0x7F --never used--
+ 0x80 COMPOSITION same as charset -- none --
+ 0x81..0x8F official dim1 same as charset -- none --
+ 0x90..0x99 official dim2 same as charset -- none --
+ 0x9A..0x9F --never used--
+ 0xA0..0xDF private dim1 0x9A same as charset
+ of 1-column width
+ 0xE0..0xEF private dim1 0x9B same as charset
+ of 2-column width
+ 0xF0..0xF4 private dim2 0x9C same as charset
+ of 1-column width
+ 0xF5..0xFE private dim2 0x9D same as charset
+ of 2-column width
+ 0xFF --never used--
+ ---------------------------------------------------------------------------
+
+ In the table, "COMPOSITION" means a charset for a composite
+ character which is a character composed from several (up to 16)
+ non-composite characters (components). Although a composite
+ character can contain components of many charsets, a composite
+ character itself belongs to the charset CHARSET-COMPOSITION. See
+ the document "GENERAL NOTE on COMPOSITE CHARACTER" below for more
+ detail.
+
+*/
+
+/* Definition of special leading-codes. */
+/* Base leading-code. */
+/* Special leading-code followed by components of a composite character. */
+#define LEADING_CODE_COMPOSITION 0x80
+/* Leading-code followed by extended leading-code. */
+#define LEADING_CODE_PRIVATE_11 0x9A /* for private DIMENSION1 of 1-column */
+#define LEADING_CODE_PRIVATE_12 0x9B /* for private DIMENSION1 of 2-column */
+#define LEADING_CODE_PRIVATE_21 0x9C /* for private DIMENSION2 of 1-column */
+#define LEADING_CODE_PRIVATE_22 0x9D /* for private DIMENSION2o f 2-column */
+
+/* Extended leading-code. */
+/* Start of each extended leading-codes. */
+#define LEADING_CODE_EXT_11 0xA0 /* follows LEADING_CODE_PRIVATE_11 */
+#define LEADING_CODE_EXT_12 0xE0 /* follows LEADING_CODE_PRIVATE_12 */
+#define LEADING_CODE_EXT_21 0xF0 /* follows LEADING_CODE_PRIVATE_21 */
+#define LEADING_CODE_EXT_22 0xF5 /* follows LEADING_CODE_PRIVATE_22 */
+/* Maximum value of extended leading-codes. */
+#define LEADING_CODE_EXT_MAX 0xFE
+
+/* Definition of minimum/maximum charset of each DIMENSION. */
+#define MIN_CHARSET_OFFICIAL_DIMENSION1 0x81
+#define MAX_CHARSET_OFFICIAL_DIMENSION1 0x8F
+#define MIN_CHARSET_OFFICIAL_DIMENSION2 0x90
+#define MAX_CHARSET_OFFICIAL_DIMENSION2 0x99
+#define MIN_CHARSET_PRIVATE_DIMENSION1 LEADING_CODE_EXT_11
+#define MIN_CHARSET_PRIVATE_DIMENSION2 LEADING_CODE_EXT_21
+
+/* Definition of special charsets. */
+#define CHARSET_ASCII 0
+#define CHARSET_COMPOSITION 0x80
+
+extern int charset_ascii; /* ASCII */
+extern int charset_composition; /* for a composite character */
+extern int charset_latin_iso8859_1; /* ISO8859-1 (Latin-1) */
+extern int charset_jisx0208_1978; /* JISX0208.1978 (Japanese Kanji old set) */
+extern int charset_jisx0208; /* JISX0208.1983 (Japanese Kanji) */
+extern int charset_katakana_jisx0201; /* JISX0201.Kana (Japanese Katakana) */
+extern int charset_latin_jisx0201; /* JISX0201.Roman (Japanese Roman) */
+extern int charset_big5_1; /* Big5 Level 1 (Chinese Traditional) */
+extern int charset_big5_2; /* Big5 Level 2 (Chinese Traditional) */
+
+/* Check if STR points the head of multi-byte form, i.e. *STR is an
+ ASCII character or a base leading-code. */
+#define CHAR_HEAD_P(str) ((unsigned char) *(str) < 0xA0)
+
+/*** GENERAL NOTE on CHARACTER REPRESENTATION ***
+
+ At first, the term "character" or "char" is used for a multilingual
+ character (of course, including ASCII character), not for a byte in
+ computer memory. We use the term "code" or "byte" for the latter
+ case.
+
+ A character is identified by charset and one or two POSITION-CODEs.
+ POSITION-CODE is the position of the character in the charset. A
+ character of DIMENSION1 charset has one POSITION-CODE: POSITION-CODE-1.
+ A character of DIMENSION2 charset has two POSITION-CODE:
+ POSITION-CODE-1 and POSITION-CODE-2. The code range of
+ POSITION-CODE is 0x20..0x7F.
+
+ Emacs has two kinds of representation of a character: multi-byte
+ form (for buffer and string) and single-word form (for character
+ object in Emacs Lisp). The latter is called "character code" here
+ after. Both representation encode the information of charset and
+ POSITION-CODE but in a different way (for instance, MSB of
+ POSITION-CODE is set in multi-byte form).
+
+ For details of multi-byte form, see the section "2. Emacs internal
+ format handlers" of `coding.c'.
+
+ Emacs uses 19 bits for a character code. The bits are divided into
+ 3 fields: FIELD1(5bits):FIELD2(7bits):FIELD3(7bits).
+
+ A character code of DIMENSION1 character uses FIELD2 to hold charset
+ and FIELD3 to hold POSITION-CODE-1. A character code of DIMENSION2
+ character uses FIELD1 to hold charset, FIELD2 and FIELD3 to hold
+ POSITION-CODE-1 and POSITION-CODE-2 respectively.
+
+ More precisely...
+
+ FIELD2 of DIMENSION1 character (except for ASCII) is "charset - 0x70".
+ This is to make all character codes except for ASCII greater than
+ 256 (ASCII's FIELD2 is 0). So, the range of FIELD2 of DIMENSION1
+ character is 0 or 0x11..0x7F.
+
+ FIELD1 of DIMENSION2 character is "charset - 0x8F" for official
+ charset and "charset - 0xE0" for private charset. So, the range of
+ FIELD1 of DIMENSION2 character is 0x01..0x1E.
+
+ -----------------------------------------------------------------------
+ charset FIELD1 (5-bit) FIELD2 (7-bit) FIELD3 (7-bit)
+ -----------------------------------------------------------------------
+ ASCII 0 0 POSITION-CODE-1
+ DIMENSION1 0 charset - 0x70 POSITION-CODE-1
+ DIMENSION2(o) charset - 0x8F POSITION-CODE-1 POSITION-CODE-2
+ DIMENSION2(p) charset - 0xE0 POSITION-CODE-1 POSITION-CODE-2
+ -----------------------------------------------------------------------
+ "(o)": official, "(p)": private
+ -----------------------------------------------------------------------
+
+*/
+
+/*** GENERAL NOTE on COMPOSITE CHARACTER ***
+
+ A composite character is a character composed from several (up to
+ 16) non-composite characters (components). Although each components
+ can belong to any charset, a composite character itself belongs to
+ the charset `charset-composition' and is assigned a special
+ leading-code `LEADING_CODE_COMPOSITION' for multi-byte form. See
+ the document "2. Emacs internal format handlers" in `coding.c' for
+ more detail about multi-byte form.
+
+ A character code of composite character has special format. In the
+ above document, FIELD1 of a composite character is 0x1F. Each
+ composite character is assigned a sequential number CMPCHAR-ID.
+ FIELD2 and FIELD3 are combined to make 14bits field for holding
+ CMPCHAR-ID, which means that Emacs can handle at most 2^14 (= 16384)
+ composite characters at once.
+
+ -----------------------------------------------------------------------
+ charset FIELD1 (5-bit) FIELD2&3 (14-bit)
+ -----------------------------------------------------------------------
+ CHARSET-COMPOSITION 0x1F CMPCHAR-ID
+ -----------------------------------------------------------------------
+
+ Emacs assigns CMPCHAR-ID to a composite character only when it
+ requires the character code of the composite character (e.g. while
+ displaying the composite character).
+
+*/
+
+/* Masks of each field of character code. */
+#define CHAR_FIELD1_MASK (0x1F << 14)
+#define CHAR_FIELD2_MASK (0x7F << 7)
+#define CHAR_FIELD3_MASK 0x7F
+
+/* Macros to access each field of character C. */
+#define CHAR_FIELD1(c) (((c) & CHAR_FIELD1_MASK) >> 14)
+#define CHAR_FIELD2(c) (((c) & CHAR_FIELD2_MASK) >> 7)
+#define CHAR_FIELD3(c) ((c) & CHAR_FIELD3_MASK)
+
+/* Minimum character code of character of each DIMENSION. */
+#define MIN_CHAR_OFFICIAL_DIMENSION1 \
+ ((MIN_CHARSET_OFFICIAL_DIMENSION1 - 0x70) << 7)
+#define MIN_CHAR_PRIVATE_DIMENSION1 \
+ ((MIN_CHARSET_PRIVATE_DIMENSION1 - 0x70) << 7)
+#define MIN_CHAR_OFFICIAL_DIMENSION2 \
+ ((MIN_CHARSET_OFFICIAL_DIMENSION2 - 0x8F) << 14)
+#define MIN_CHAR_PRIVATE_DIMENSION2 \
+ ((MIN_CHARSET_PRIVATE_DIMENSION2 - 0xE0) << 14)
+#define MIN_CHAR_COMPOSITION \
+ (0x1F << 14)
+
+/* 1 if C is an ASCII character, else 0. */
+#define SINGLE_BYTE_CHAR_P(c) ((c) < 0x100)
+/* 1 if C is an composite character, else 0. */
+#define COMPOSITE_CHAR_P(c) ((c) >= MIN_CHAR_COMPOSITION)
+
+/* A char-table containing information of each character set.
+
+ Unlike ordinary char-tables, this doesn't contain any nested table.
+ Only the top level elements are used. Each element is a vector of
+ the following information:
+ CHARSET-ID, BYTES, DIMENSION, CHARS, WIDTH, DIRECTION,
+ LEADING-CODE-BASE, LEADING-CODE-EXT,
+ ISO-FINAL-CHAR, ISO-GRAPHIC-PLANE,
+ REVERSE-CHARSET, SHORT-NAME, LONG-NAME, DESCRIPTION,
+ PLIST.
+
+ CHARSET-ID (integer) is the identification number of the charset.
+
+ BYTE (integer) is the length of multi-byte form of a character in
+ the charset: one of 1, 2, 3, and 4.
+
+ DIMENSION (integer) is the number of bytes to represent a character: 1 or 2.
+
+ CHARS (integer) is the number of characters in a dimension: 94 or 96.
+
+ WIDTH (integer) is the number of columns a character in the charset
+ occupies on the screen: one of 0, 1, and 2.
+
+ DIRECTION (integer) is the rendering direction of characters in the
+ charset when rendering. If 0, render from right to left, else
+ render from left to right.
+
+ LEADING-CODE-BASE (integer) is the base leading-code for the
+ charset.
+
+ LEADING-CODE-EXT (integer) is the extended leading-code for the
+ charset. All charsets of less than 0xA0 has the value 0.
+
+ ISO-FINAL-CHAR (character) is the final character of the
+ corresponding ISO 2022 charset.
+
+ ISO-GRAPHIC-PLANE (integer) is the graphic plane to be invoked
+ while encoding to variants of ISO 2022 coding system, one of the
+ following: 0/graphic-plane-left(GL), 1/graphic-plane-right(GR).
+
+ REVERSE-CHARSET (integer) is the charset which differs only in
+ LEFT-TO-RIGHT value from the charset. If there's no such a
+ charset, the value is -1.
+
+ SHORT-NAME (string) is the short name to refer to the charset.
+
+ LONG-NAME (string) is the long name to refer to the charset.
+
+ DESCRIPTION (string) is the description string of the charset.
+
+ PLIST (property list) may contain any type of information a user
+ want to put and get by functions `put-charset-property' and
+ `get-charset-property' respectively. */
+extern Lisp_Object Vcharset_table;
+
+/* Macros to access various information of CHARSET in Vcharset_table.
+ We provide these macros for efficiency. No range check of CHARSET. */
+
+/* Return entry of CHARSET (lisp integer) in Vcharset_table. */
+#define CHARSET_TABLE_ENTRY(charset) \
+ XCHAR_TABLE (Vcharset_table)->contents[charset]
+
+/* Return information INFO-IDX of CHARSET. */
+#define CHARSET_TABLE_INFO(charset, info_idx) \
+ XVECTOR (CHARSET_TABLE_ENTRY (charset))->contents[info_idx]
+
+#define CHARSET_ID_IDX (0)
+#define CHARSET_BYTES_IDX (1)
+#define CHARSET_DIMENSION_IDX (2)
+#define CHARSET_CHARS_IDX (3)
+#define CHARSET_WIDTH_IDX (4)
+#define CHARSET_DIRECTION_IDX (5)
+#define CHARSET_LEADING_CODE_BASE_IDX (6)
+#define CHARSET_LEADING_CODE_EXT_IDX (7)
+#define CHARSET_ISO_FINAL_CHAR_IDX (8)
+#define CHARSET_ISO_GRAPHIC_PLANE_IDX (9)
+#define CHARSET_REVERSE_CHARSET_IDX (10)
+#define CHARSET_SHORT_NAME_IDX (11)
+#define CHARSET_LONG_NAME_IDX (12)
+#define CHARSET_DESCRIPTION_IDX (13)
+#define CHARSET_PLIST_IDX (14)
+/* Size of a vector of each entry of Vcharset_table. */
+#define CHARSET_MAX_IDX (15)
+
+/* And several more macros to be used frequently. */
+#define CHARSET_BYTES(charset) \
+ XFASTINT (CHARSET_TABLE_INFO (charset, CHARSET_BYTES_IDX))
+#define CHARSET_DIMENSION(charset) \
+ XFASTINT (CHARSET_TABLE_INFO (charset, CHARSET_DIMENSION_IDX))
+#define CHARSET_CHARS(charset) \
+ XFASTINT (CHARSET_TABLE_INFO (charset, CHARSET_CHARS_IDX))
+#define CHARSET_WIDTH(charset) \
+ XFASTINT (CHARSET_TABLE_INFO (charset, CHARSET_WIDTH_IDX))
+#define CHARSET_DIRECTION(charset) \
+ XFASTINT (CHARSET_TABLE_INFO (charset, CHARSET_DIRECTION_IDX))
+#define CHARSET_LEADING_CODE_BASE(charset) \
+ XFASTINT (CHARSET_TABLE_INFO (charset, CHARSET_LEADING_CODE_BASE_IDX))
+#define CHARSET_LEADING_CODE_EXT(charset) \
+ XFASTINT (CHARSET_TABLE_INFO (charset, CHARSET_LEADING_CODE_EXT_IDX))
+#define CHARSET_ISO_FINAL_CHAR(charset) \
+ XFASTINT (CHARSET_TABLE_INFO (charset, CHARSET_ISO_FINAL_CHAR_IDX))
+#define CHARSET_ISO_GRAPHIC_PLANE(charset) \
+ XFASTINT (CHARSET_TABLE_INFO (charset, CHARSET_ISO_GRAPHIC_PLANE_IDX))
+#define CHARSET_REVERSE_CHARSET(charset) \
+ XINT (CHARSET_TABLE_INFO (charset, CHARSET_REVERSE_CHARSET_IDX))
+
+/* Macros to specify direction of a charset. */
+#define CHARSET_DIRECTION_LEFT_TO_RIGHT 0
+#define CHARSET_DIRECTION_RIGHT_TO_LEFT 1
+
+/* A vector of charset symbol indexed by charset-id. This is used
+ only for returning charset symbol from C functions. */
+extern Lisp_Object Vcharset_symbol_table;
+
+/* Return symbol of CHARSET. */
+#define CHARSET_SYMBOL(charset) \
+ XVECTOR (Vcharset_symbol_table)->contents[charset]
+
+/* 1 if CHARSET is valid, else 0. */
+#define CHARSET_VALID_P(charset) \
+ ((charset) == 0 \
+ || ((charset) >= 0x80 && (charset) <= MAX_CHARSET_OFFICIAL_DIMENSION2) \
+ || ((charset) >= MIN_CHARSET_PRIVATE_DIMENSION1 && (charset) < MAX_CHARSET))
+
+/* 1 if CHARSET is already defined, else 0. */
+#define CHARSET_DEFINED_P(charset) \
+ (((charset) >= 0) && ((charset) < MAX_CHARSET) \
+ && !NILP (CHARSET_TABLE_ENTRY (charset)))
+
+/* Since the information CHARSET-BYTES and CHARSET-WIDTH of
+ Vcharset_table can be retrieved only from the first byte of
+ multi-byte form (an ASCII code or a base leading-code), we provide
+ here tables to be used by macros BYTES_BY_CHAR_HEAD and
+ WIDTH_BY_CHAR_HEAD for faster information retrieval. */
+extern int bytes_by_char_head[256];
+extern int width_by_char_head[256];
+
+#define BYTES_BY_CHAR_HEAD(char_head) bytes_by_char_head[char_head]
+#define WIDTH_BY_CHAR_HEAD(char_head) width_by_char_head[char_head]
+
+/* Charset of the character C. */
+#define CHAR_CHARSET(c) \
+ (SINGLE_BYTE_CHAR_P (c) \
+ ? CHARSET_ASCII \
+ : ((c) < MIN_CHAR_OFFICIAL_DIMENSION2 \
+ ? CHAR_FIELD2 (c) + 0x70 \
+ : ((c) < MIN_CHAR_PRIVATE_DIMENSION2 \
+ ? CHAR_FIELD1 (c) + 0x8F \
+ : ((c) < MIN_CHAR_COMPOSITION \
+ ? CHAR_FIELD1 (c) + 0xE0 \
+ : CHARSET_COMPOSITION))))
+
+/* Return charset at the place pointed by P. */
+#define CHARSET_AT(p) \
+ (*(p) < 0x80 \
+ ? CHARSET_ASCII \
+ : (*(p) == LEADING_CODE_COMPOSITION \
+ ? CHARSET_COMPOSITION \
+ : (*(p) < LEADING_CODE_PRIVATE_11 \
+ ? (int)*(p) \
+ : (*(p) <= LEADING_CODE_PRIVATE_22 \
+ ? (int)*((p) + 1) \
+ : -1))))
+
+/* Same as `CHARSET_AT ()' but perhaps runs faster because of an
+ additional argument C which is the code (byte) at P. */
+#define FIRST_CHARSET_AT(p, c) \
+ ((c) < 0x80 \
+ ? CHARSET_ASCII \
+ : ((c) == LEADING_CODE_COMPOSITION \
+ ? CHARSET_COMPOSITION \
+ : ((c) < LEADING_CODE_PRIVATE_11 \
+ ? (int)(c) \
+ : ((c) <= LEADING_CODE_PRIVATE_22 \
+ ? (int)*((p) + 1) \
+ : -1))))
+
+/* Check if two characters C1 and C2 belong to the same charset.
+ Always return 0 for composite characters. */
+#define SAME_CHARSET_P(c1, c2) \
+ (c1 < MIN_CHAR_COMPOSITION \
+ && (SINGLE_BYTE_CHAR_P (c1) \
+ ? SINGLE_BYTE_CHAR_P (c2) \
+ : (c1 < MIN_CHAR_OFFICIAL_DIMENSION2 \
+ ? (c1 & CHAR_FIELD2_MASK) == (c2 & CHAR_FIELD2_MASK) \
+ : (c1 & CHAR_FIELD1_MASK) == (c2 & CHAR_FIELD1_MASK))))
+
+/* Return a non-ASCII character of which charset is CHARSET and
+ position-codes are C1 and C2. DIMENSION1 character ignores C2. */
+#define MAKE_NON_ASCII_CHAR(charset, c1, c2) \
+ ((charset) == CHARSET_COMPOSITION \
+ ? MAKE_COMPOSITE_CHAR (((c1) << 7) + (c2)) \
+ : (CHARSET_DIMENSION (charset) == 1 \
+ ? (((charset) - 0x70) << 7) | (c1) \
+ : ((charset) < MIN_CHARSET_PRIVATE_DIMENSION2 \
+ ? (((charset) - 0x8F) << 14) | ((c1) << 7) | (c2) \
+ : (((charset) - 0xE0) << 14) | ((c1) << 7) | (c2))))
+
+/* Return a composite character of which CMPCHAR-ID is ID. */
+#define MAKE_COMPOSITE_CHAR(id) (MIN_CHAR_COMPOSITION + (id))
+
+/* Return CMPCHAR-ID of a composite character C. */
+#define COMPOSITE_CHAR_ID(c) ((c) - MIN_CHAR_COMPOSITION)
+
+/* Return a character of which charset is CHARSET and position-codes
+ are C1 and C2. DIMENSION1 character ignores C2. */
+#define MAKE_CHAR(charset, c1, c2) \
+ ((charset) == CHARSET_ASCII \
+ ? (c1) \
+ : MAKE_NON_ASCII_CHAR ((charset), (c1) & 0x7F, (c2) & 0x7F))
+
+/* The charset of non-ASCII character C is set to CHARSET, and the
+ position-codes of C are set to C1 and C2. C2 of DIMENSION1 character
+ is 0. */
+#define SPLIT_NON_ASCII_CHAR(c, charset, c1, c2) \
+ ((c) < MIN_CHAR_OFFICIAL_DIMENSION2 \
+ ? (charset = CHAR_FIELD2 (c) + 0x70, \
+ c1 = CHAR_FIELD3 (c), \
+ c2 = 0) \
+ : (charset = ((c) < MIN_CHAR_COMPOSITION \
+ ? (CHAR_FIELD1 (c) \
+ + ((c) < MIN_CHAR_PRIVATE_DIMENSION2 ? 0x8F : 0xE0)) \
+ : CHARSET_COMPOSITION), \
+ c1 = CHAR_FIELD2 (c), \
+ c2 = CHAR_FIELD3 (c)))
+
+/* The charset of character C is set to CHARSET, and the
+ position-codes of C are set to C1 and C2. C2 of DIMENSION1 character
+ is 0. */
+#define SPLIT_CHAR(c, charset, c1, c2) \
+ (SINGLE_BYTE_CHAR_P (c) \
+ ? charset = CHARSET_ASCII, c1 = (c), c2 = 0 \
+ : SPLIT_NON_ASCII_CHAR (c, charset, c1, c2))
+
+/* The charset of the character at STR is set to CHARSET, and the
+ position-codes are set to C1 and C2. C2 of DIMENSION1 character is 0.
+ If the character is a composite character, the upper 7-bit and
+ lower 7-bit of CMPCHAR-ID are set in C1 and C2 respectively. No
+ range checking. */
+#define SPLIT_STRING(str, len, charset, c1, c2) \
+ ((BYTES_BY_CHAR_HEAD ((unsigned char) *(str)) < 2 \
+ || BYTES_BY_CHAR_HEAD ((unsigned char) *(str)) > len \
+ || split_non_ascii_string (str, len, &charset, &c1, &c2, 0) < 0) \
+ ? c1 = *(str), charset = CHARSET_ASCII \
+ : charset)
+
+#define MAX_CHARSET 0xFF
+
+/* Mapping table from ISO2022's charset (specified by DIMENSION,
+ CHARS, and FINAL_CHAR) to Emacs' charset. Should be accessed by
+ macro ISO_CHARSET_TABLE (DIMENSION, CHARS, FINAL_CHAR). */
+extern int iso_charset_table[2][2][128];
+
+#define ISO_CHARSET_TABLE(dimension, chars, final_char) \
+ iso_charset_table[XINT (dimension) - 1][XINT (chars) > 94][XINT (final_char)]
+
+#define BASE_LEADING_CODE_P(c) (BYTES_BY_CHAR_HEAD ((unsigned char) (c)) > 1)
+
+/* The following two macros CHAR_STRING and STRING_CHAR are the main
+ entry points to convert between Emacs two types of character
+ representations: multi-byte form and single-word form (character
+ code). */
+
+/* Set STR a pointer to the multi-byte form of the character C. If C
+ is not a composite character, the multi-byte form is set in WORKBUF
+ and STR points WORKBUF. The caller should allocate at least 4-byte
+ area at WORKBUF in advance. Returns the length of the multi-byte
+ form. */
+
+#define CHAR_STRING(c, workbuf, str) \
+ (SINGLE_BYTE_CHAR_P (c) \
+ ? *(str = workbuf) = (unsigned char)(c), 1 \
+ : non_ascii_char_to_string (c, workbuf, &str))
+
+/* Return a character code of the character of which multi-byte form
+ is at STR and the length is LEN. If STR doesn't contain valid
+ multi-byte form, only the first byte in STR is returned. */
+
+#define STRING_CHAR(str, len) \
+ ((BYTES_BY_CHAR_HEAD ((unsigned char) *(str)) == 1 \
+ || BYTES_BY_CHAR_HEAD ((unsigned char) *(str)) > (len)) \
+ ? (unsigned char) *(str) \
+ : string_to_non_ascii_char (str, len, 0))
+
+/* This is like STRING_CHAR but the third arg ACTUAL_LEN is set to
+ the length of the multi-byte form. Just to know the length, use
+ MULTIBYTE_FORM_LENGTH. */
+
+#define STRING_CHAR_AND_LENGTH(str, len, actual_len) \
+ ((BYTES_BY_CHAR_HEAD ((unsigned char) *(str)) == 1 \
+ || BYTES_BY_CHAR_HEAD ((unsigned char) *(str)) > (len)) \
+ ? (actual_len = 1), (unsigned char) *(str) \
+ : string_to_non_ascii_char (str, len, &actual_len))
+
+/* Return the length of the multi-byte form at string STR of length LEN. */
+
+#define MULTIBYTE_FORM_LENGTH(str, len) \
+ ((BYTES_BY_CHAR_HEAD (*(unsigned char *)(str)) == 1 \
+ || BYTES_BY_CHAR_HEAD (*(unsigned char *)(str)) > (len)) \
+ ? 1 \
+ : multibyte_form_length (str, len))
+
+/* Set C a (possibly multibyte) character at P. P points into a
+ string which is the virtual concatenation of STR1 (which ends at
+ END1) or STR2 (which ends at END2). */
+
+#define GET_CHAR_AFTER_2(c, p, str1, end1, str2, end2) \
+ do { \
+ const char *dtemp = (p) == (end1) ? (str2) : (p); \
+ const char *dlimit = ((p) >= (str1) && (p) < (end1)) ? (end1) : (end2); \
+ c = STRING_CHAR (dtemp, dlimit - dtemp); \
+ } while (0)
+
+/* Set C a (possibly multibyte) character before P. P points into a
+ string which is the virtual concatenation of STR1 (which ends at
+ END1) or STR2 (which ends at END2). */
+
+#define GET_CHAR_BEFORE_2(c, p, str1, end1, str2, end2) \
+ do { \
+ const char *dtemp = (p); \
+ const char *dlimit = ((p) > (str2) && (p) <= (end2)) ? (str2) : (str1); \
+ while (dtemp-- > dlimit && (unsigned char) *dtemp >= 0xA0); \
+ c = STRING_CHAR (dtemp, p - dtemp); \
+ } while (0)
+
+#ifdef emacs
+
+/* Increase the buffer point POS of the current buffer to the next
+ character boundary. This macro relies on the fact that *GPT_ADDR
+ and *Z_ADDR are always accessible and the values are '\0'. No
+ range checking of POS. */
+#define INC_POS(pos) \
+ do { \
+ unsigned char *p = POS_ADDR (pos) + 1; \
+ pos++; \
+ while (!CHAR_HEAD_P (p)) p++, pos++; \
+ } while (0)
+
+/* Decrease the buffer point POS of the current buffer to the previous
+ character boundary. No range checking of POS. */
+#define DEC_POS(pos) \
+ do { \
+ unsigned char *p, *p_min; \
+ if (--pos < GPT) \
+ p = BEG_ADDR + pos - 1, p_min = BEG_ADDR; \
+ else \
+ p = BEG_ADDR + GAP_SIZE + pos - 1, p_min = GAP_END_ADDR; \
+ while (p > p_min && !CHAR_HEAD_P (p)) p--, pos--; \
+ } while (0)
+
+#endif /* emacs */
+
+/* Maximum counts of components in one composite character. */
+#define MAX_COMPONENT_COUNT 16
+
+/* Structure to hold information of a composite character. */
+struct cmpchar_info {
+ /* Byte length of the composite character. */
+ int len;
+
+ /* Multi-byte form of the composite character. */
+ unsigned char *data;
+
+ /* Length of glyph codes. */
+ int glyph_len;
+
+ /* Width of the overall glyph of the composite character. */
+ int width;
+
+ /* Pointer to an array of glyph codes of the composite character.
+ This actually contains only character code, no face. */
+ GLYPH *glyph;
+
+ /* Pointer to an array of composition rules. The value has the form:
+ (0xA0 + ((GLOBAL-REF-POINT << 2) | NEW-REF-POINT))
+ where each XXX-REF-POINT is 0..8. */
+ unsigned char *cmp_rule;
+
+ /* Pointer to an array of x-axis offset of left edge of glyphs
+ relative to the left of of glyph[0] except for the first element
+ which is the absolute offset from the left edge of overall glyph.
+ The actual pixel offset should be calculated by multiplying each
+ frame's one column width by this value:
+ (i.e. FONT_WIDTH (f->output_data.x->font) * col_offset[N]). */
+ float *col_offset;
+
+ /* Work slot used by `dumpglyphs' (xterm.c). */
+ int face_work;
+};
+
+/* Table of pointers to the structure `cmpchar_info' indexed by
+ CMPCHAR-ID. */
+extern struct cmpchar_info **cmpchar_table;
+/* Number of the current composite characters. */
+extern int n_cmpchars;
+
+/* This is the maximum length of multi-byte form. */
+#define MAX_LENGTH_OF_MULTI_BYTE_FORM (MAX_COMPONENT_COUNT * 6)
+
+#endif /* _CHARSET_H */
+
--- /dev/null
+/* Coding system handler (conversion, detection, and etc).
+ Ver.1.0.
+
+ Copyright (C) 1995 Free Software Foundation, Inc.
+ Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+/*** TABLE OF CONTENTS ***
+
+ 1. Preamble
+ 2. Emacs' internal format handlers
+ 3. ISO2022 handlers
+ 4. Shift-JIS and BIG5 handlers
+ 5. End-of-line handlers
+ 6. C library functions
+ 7. Emacs Lisp library functions
+ 8. Post-amble
+
+*/
+
+/*** GENERAL NOTE on CODING SYSTEM ***
+
+ Coding system is an encoding mechanism of one or more character
+ sets. Here's a list of coding systems which Emacs can handle. When
+ we say "decode", it means converting some other coding system to
+ Emacs' internal format, and when we say "encode", it means
+ converting Emacs' internal format to some other coding system.
+
+ 0. Emacs' internal format
+
+ Emacs itself holds a multi-lingual character in a buffer and a string
+ in a special format. Details are described in the section 2.
+
+ 1. ISO2022
+
+ The most famous coding system for multiple character sets. X's
+ Compound Text, various EUCs (Extended Unix Code), and such coding
+ systems used in Internet communication as ISO-2022-JP are all
+ variants of ISO2022. Details are described in the section 3.
+
+ 2. SJIS (or Shift-JIS or MS-Kanji-Code)
+
+ A coding system to encode character sets: ASCII, JISX0201, and
+ JISX0208. Widely used for PC's in Japan. Details are described in
+ the section 4.
+
+ 3. BIG5
+
+ A coding system to encode character sets: ASCII and Big5. Widely
+ used by Chinese (mainly in Taiwan and Hong Kong). Details are
+ described in the section 4. In this file, when written as "BIG5"
+ (all uppercase), it means the coding system, and when written as
+ "Big5" (capitalized), it means the character set.
+
+ 4. Else
+
+ If a user want to read/write a text encoded in a coding system not
+ listed above, he can supply a decoder and an encoder for it in CCL
+ (Code Conversion Language) programs. Emacs executes the CCL program
+ while reading/writing.
+
+ Emacs represent a coding-system by a Lisp symbol that has a property
+ `coding-system'. But, before actually using the coding-system, the
+ information about it is set in a structure of type `struct
+ coding_system' for rapid processing. See the section 6 for more
+ detail.
+
+*/
+
+/*** GENERAL NOTES on END-OF-LINE FORMAT ***
+
+ How end-of-line of a text is encoded depends on a system. For
+ instance, Unix's format is just one byte of `line-feed' code,
+ whereas DOS's format is two bytes sequence of `carriage-return' and
+ `line-feed' codes. MacOS's format is one byte of `carriage-return'.
+
+ Since how characters in a text is encoded and how end-of-line is
+ encoded is independent, any coding system described above can take
+ any format of end-of-line. So, Emacs has information of format of
+ end-of-line in each coding-system. See the section 6 for more
+ detail.
+
+*/
+
+/*** GENERAL NOTES on `detect_coding_XXX ()' functions ***
+
+ These functions check if a text between SRC and SRC_END is encoded
+ in the coding system category XXX. Each returns an integer value in
+ which appropriate flag bits for the category XXX is set. The flag
+ bits are defined in macros CODING_CATEGORY_MASK_XXX. Below is the
+ template of these functions. */
+#if 0
+int
+detect_coding_internal (src, src_end)
+ unsigned char *src, *src_end;
+{
+ ...
+}
+#endif
+
+/*** GENERAL NOTES on `decode_coding_XXX ()' functions ***
+
+ These functions decode SRC_BYTES length text at SOURCE encoded in
+ CODING to Emacs' internal format. The resulting text goes to a
+ place pointed by DESTINATION, the length of which should not exceed
+ DST_BYTES. The bytes actually processed is returned as *CONSUMED.
+ The return value is the length of the decoded text. Below is a
+ template of these functions. */
+#if 0
+decode_coding_XXX (coding, source, destination, src_bytes, dst_bytes, consumed)
+ struct coding_system *coding;
+ unsigned char *source, *destination;
+ int src_bytes, dst_bytes;
+ int *consumed;
+{
+ ...
+}
+#endif
+
+/*** GENERAL NOTES on `encode_coding_XXX ()' functions ***
+
+ These functions encode SRC_BYTES length text at SOURCE of Emacs
+ internal format to CODING. The resulting text goes to a place
+ pointed by DESTINATION, the length of which should not exceed
+ DST_BYTES. The bytes actually processed is returned as *CONSUMED.
+ The return value is the length of the encoded text. Below is a
+ template of these functions. */
+#if 0
+encode_coding_XXX (coding, source, destination, src_bytes, dst_bytes, consumed)
+ struct coding_system *coding;
+ unsigned char *source, *destination;
+ int src_bytes, dst_bytes;
+ int *consumed;
+{
+ ...
+}
+#endif
+
+/*** COMMONLY USED MACROS ***/
+
+/* The following three macros ONE_MORE_BYTE, TWO_MORE_BYTES, and
+ THREE_MORE_BYTES safely get one, two, and three bytes from the
+ source text respectively. If there are not enough bytes in the
+ source, they jump to `label_end_of_loop'. The caller should set
+ variables `src' and `src_end' to appropriate areas in advance. */
+
+#define ONE_MORE_BYTE(c1) \
+ do { \
+ if (src < src_end) \
+ c1 = *src++; \
+ else \
+ goto label_end_of_loop; \
+ } while (0)
+
+#define TWO_MORE_BYTES(c1, c2) \
+ do { \
+ if (src + 1 < src_end) \
+ c1 = *src++, c2 = *src++; \
+ else \
+ goto label_end_of_loop; \
+ } while (0)
+
+#define THREE_MORE_BYTES(c1, c2, c3) \
+ do { \
+ if (src + 2 < src_end) \
+ c1 = *src++, c2 = *src++, c3 = *src++; \
+ else \
+ goto label_end_of_loop; \
+ } while (0)
+
+/* The following three macros DECODE_CHARACTER_ASCII,
+ DECODE_CHARACTER_DIMENSION1, and DECODE_CHARACTER_DIMENSION2 put
+ the multi-byte form of a character of each class at the place
+ pointed by `dst'. The caller should set the variable `dst' to
+ point to an appropriate area and the variable `coding' to point to
+ the coding-system of the currently decoding text in advance. */
+
+/* Decode one ASCII character C. */
+
+#define DECODE_CHARACTER_ASCII(c) \
+ do { \
+ if (COMPOSING_P (coding->composing)) \
+ *dst++ = 0xA0, *dst++ = (c) | 0x80; \
+ else \
+ *dst++ = (c); \
+ } while (0)
+
+/* Decode one DIMENSION1 character of which charset is CHARSET and
+ position-code is C. */
+
+#define DECODE_CHARACTER_DIMENSION1(charset, c) \
+ do { \
+ unsigned char leading_code = CHARSET_LEADING_CODE_BASE (charset); \
+ if (COMPOSING_P (coding->composing)) \
+ *dst++ = leading_code + 0x20; \
+ else \
+ *dst++ = leading_code; \
+ if (leading_code = CHARSET_LEADING_CODE_EXT (charset)) \
+ *dst++ = leading_code; \
+ *dst++ = (c) | 0x80; \
+ } while (0)
+
+/* Decode one DIMENSION2 character of which charset is CHARSET and
+ position-codes are C1 and C2. */
+
+#define DECODE_CHARACTER_DIMENSION2(charset, c1, c2) \
+ do { \
+ DECODE_CHARACTER_DIMENSION1 (charset, c1); \
+ *dst++ = (c2) | 0x80; \
+ } while (0)
+
+\f
+/*** 1. Preamble ***/
+
+#include <stdio.h>
+
+#ifdef emacs
+
+#include <config.h>
+#include "lisp.h"
+#include "buffer.h"
+#include "charset.h"
+#include "ccl.h"
+#include "coding.h"
+#include "window.h"
+
+#else /* not emacs */
+
+#include "mulelib.h"
+
+#endif /* not emacs */
+
+Lisp_Object Qcoding_system, Qeol_type;
+Lisp_Object Qbuffer_file_coding_system;
+Lisp_Object Qpost_read_conversion, Qpre_write_conversion;
+
+extern Lisp_Object Qinsert_file_contents, Qwrite_region;
+Lisp_Object Qcall_process, Qcall_process_region, Qprocess_argument;
+Lisp_Object Qstart_process, Qopen_network_stream;
+Lisp_Object Qtarget_idx;
+
+/* Mnemonic character of each format of end-of-line. */
+int eol_mnemonic_unix, eol_mnemonic_dos, eol_mnemonic_mac;
+/* Mnemonic character to indicate format of end-of-line is not yet
+ decided. */
+int eol_mnemonic_undecided;
+
+#ifdef emacs
+
+Lisp_Object Qcoding_system_vector, Qcoding_system_p, Qcoding_system_error;
+
+/* Coding-systems are handed between Emacs Lisp programs and C internal
+ routines by the following three variables. */
+/* Coding-system for reading files and receiving data from process. */
+Lisp_Object Vcoding_system_for_read;
+/* Coding-system for writing files and sending data to process. */
+Lisp_Object Vcoding_system_for_write;
+/* Coding-system actually used in the latest I/O. */
+Lisp_Object Vlast_coding_system_used;
+
+/* Coding-system of what terminal accept for displaying. */
+struct coding_system terminal_coding;
+
+/* Coding-system of what is sent from terminal keyboard. */
+struct coding_system keyboard_coding;
+
+Lisp_Object Vcoding_system_alist;
+
+#endif /* emacs */
+
+Lisp_Object Qcoding_category_index;
+
+/* List of symbols `coding-category-xxx' ordered by priority. */
+Lisp_Object Vcoding_category_list;
+
+/* Table of coding-systems currently assigned to each coding-category. */
+Lisp_Object coding_category_table[CODING_CATEGORY_IDX_MAX];
+
+/* Table of names of symbol for each coding-category. */
+char *coding_category_name[CODING_CATEGORY_IDX_MAX] = {
+ "coding-category-internal",
+ "coding-category-sjis",
+ "coding-category-iso-7",
+ "coding-category-iso-8-1",
+ "coding-category-iso-8-2",
+ "coding-category-iso-else",
+ "coding-category-big5",
+ "coding-category-binary"
+};
+
+/* Alist of charsets vs the alternate charsets. */
+Lisp_Object Valternate_charset_table;
+
+/* Alist of charsets vs revision number. */
+Lisp_Object Vcharset_revision_alist;
+
+\f
+/*** 2. Emacs internal format handlers ***/
+
+/* Emacs' internal format for encoding multiple character sets is a
+ kind of multi-byte encoding, i.e. encoding a character by a sequence
+ of one-byte codes of variable length. ASCII characters and control
+ characters (e.g. `tab', `newline') are represented by one-byte as
+ is. It takes the range 0x00 through 0x7F. The other characters
+ are represented by a sequence of `base leading-code', optional
+ `extended leading-code', and one or two `position-code's. Length
+ of the sequence is decided by the base leading-code. Leading-code
+ takes the range 0x80 through 0x9F, whereas extended leading-code
+ and position-code take the range 0xA0 through 0xFF. See the
+ document of `charset.h' for more detail about leading-code and
+ position-code.
+
+ There's one exception in this rule. Special leading-code
+ `leading-code-composition' denotes that the following several
+ characters should be composed into one character. Leading-codes of
+ components (except for ASCII) are added 0x20. An ASCII character
+ component is represented by a 2-byte sequence of `0xA0' and
+ `ASCII-code + 0x80'. See also the document in `charset.h' for the
+ detail of composite character. Hence, we can summarize the code
+ range as follows:
+
+ --- CODE RANGE of Emacs' internal format ---
+ (character set) (range)
+ ASCII 0x00 .. 0x7F
+ ELSE (1st byte) 0x80 .. 0x9F
+ (rest bytes) 0xA0 .. 0xFF
+ ---------------------------------------------
+
+ */
+
+enum emacs_code_class_type emacs_code_class[256];
+
+/* Go to the next statement only if *SRC is accessible and the code is
+ greater than 0xA0. */
+#define CHECK_CODE_RANGE_A0_FF \
+ do { \
+ if (src >= src_end) \
+ goto label_end_of_switch; \
+ else if (*src++ < 0xA0) \
+ return 0; \
+ } while (0)
+
+/* See the above "GENERAL NOTES on `detect_coding_XXX ()' functions".
+ Check if a text is encoded in Emacs' internal format. If it is,
+ return CODING_CATEGORY_MASK_INTERNAL, else return 0. */
+
+int
+detect_coding_internal (src, src_end)
+ unsigned char *src, *src_end;
+{
+ unsigned char c;
+ int composing = 0;
+
+ while (src < src_end)
+ {
+ c = *src++;
+
+ if (composing)
+ {
+ if (c < 0xA0)
+ composing = 0;
+ else
+ c -= 0x20;
+ }
+
+ switch (emacs_code_class[c])
+ {
+ case EMACS_ascii_code:
+ case EMACS_linefeed_code:
+ break;
+
+ case EMACS_control_code:
+ if (c == ISO_CODE_ESC || c == ISO_CODE_SI || c == ISO_CODE_SO)
+ return 0;
+ break;
+
+ case EMACS_invalid_code:
+ return 0;
+
+ case EMACS_leading_code_composition: /* c == 0x80 */
+ if (composing)
+ CHECK_CODE_RANGE_A0_FF;
+ else
+ composing = 1;
+ break;
+
+ case EMACS_leading_code_4:
+ CHECK_CODE_RANGE_A0_FF;
+ /* fall down to check it two more times ... */
+
+ case EMACS_leading_code_3:
+ CHECK_CODE_RANGE_A0_FF;
+ /* fall down to check it one more time ... */
+
+ case EMACS_leading_code_2:
+ CHECK_CODE_RANGE_A0_FF;
+ break;
+
+ default:
+ label_end_of_switch:
+ break;
+ }
+ }
+ return CODING_CATEGORY_MASK_INTERNAL;
+}
+
+\f
+/*** 3. ISO2022 handlers ***/
+
+/* The following note describes the coding system ISO2022 briefly.
+ Since the intension of this note is to help understanding of the
+ programs in this file, some parts are NOT ACCURATE or OVERLY
+ SIMPLIFIED. For the thorough understanding, please refer to the
+ original document of ISO2022.
+
+ ISO2022 provides many mechanisms to encode several character sets
+ in 7-bit and 8-bit environment. If one choose 7-bite environment,
+ all text is encoded by codes of less than 128. This may make the
+ encoded text a little bit longer, but the text get more stability
+ to pass through several gateways (some of them split MSB off).
+
+ There are two kind of character set: control character set and
+ graphic character set. The former contains control characters such
+ as `newline' and `escape' to provide control functions (control
+ functions are provided also by escape sequence). The latter
+ contains graphic characters such as ' A' and '-'. Emacs recognizes
+ two control character sets and many graphic character sets.
+
+ Graphic character sets are classified into one of the following
+ four classes, DIMENSION1_CHARS94, DIMENSION1_CHARS96,
+ DIMENSION2_CHARS94, DIMENSION2_CHARS96 according to the number of
+ bytes (DIMENSION) and the number of characters in one dimension
+ (CHARS) of the set. In addition, each character set is assigned an
+ identification tag (called "final character" and denoted as <F>
+ here after) which is unique in each class. <F> of each character
+ set is decided by ECMA(*) when it is registered in ISO. Code range
+ of <F> is 0x30..0x7F (0x30..0x3F are for private use only).
+
+ Note (*): ECMA = European Computer Manufacturers Association
+
+ Here are examples of graphic character set [NAME(<F>)]:
+ o DIMENSION1_CHARS94 -- ASCII('B'), right-half-of-JISX0201('I'), ...
+ o DIMENSION1_CHARS96 -- right-half-of-ISO8859-1('A'), ...
+ o DIMENSION2_CHARS94 -- GB2312('A'), JISX0208('B'), ...
+ o DIMENSION2_CHARS96 -- none for the moment
+
+ A code area (1byte=8bits) is divided into 4 areas, C0, GL, C1, and GR.
+ C0 [0x00..0x1F] -- control character plane 0
+ GL [0x20..0x7F] -- graphic character plane 0
+ C1 [0x80..0x9F] -- control character plane 1
+ GR [0xA0..0xFF] -- graphic character plane 1
+
+ A control character set is directly designated and invoked to C0 or
+ C1 by an escape sequence. The most common case is that ISO646's
+ control character set is designated/invoked to C0 and ISO6429's
+ control character set is designated/invoked to C1, and usually
+ these designations/invocations are omitted in a coded text. With
+ 7-bit environment, only C0 can be used, and a control character for
+ C1 is encoded by an appropriate escape sequence to fit in the
+ environment. All control characters for C1 are defined the
+ corresponding escape sequences.
+
+ A graphic character set is at first designated to one of four
+ graphic registers (G0 through G3), then these graphic registers are
+ invoked to GL or GR. These designations and invocations can be
+ done independently. The most common case is that G0 is invoked to
+ GL, G1 is invoked to GR, and ASCII is designated to G0, and usually
+ these invocations and designations are omitted in a coded text.
+ With 7-bit environment, only GL can be used.
+
+ When a graphic character set of CHARS94 is invoked to GL, code 0x20
+ and 0x7F of GL area work as control characters SPACE and DEL
+ respectively, and code 0xA0 and 0xFF of GR area should not be used.
+
+ There are two ways of invocation: locking-shift and single-shift.
+ With locking-shift, the invocation lasts until the next different
+ invocation, whereas with single-shift, the invocation works only
+ for the following character and doesn't affect locking-shift.
+ Invocations are done by the following control characters or escape
+ sequences.
+
+ ----------------------------------------------------------------------
+ function control char escape sequence description
+ ----------------------------------------------------------------------
+ SI (shift-in) 0x0F none invoke G0 to GL
+ SI (shift-out) 0x0E none invoke G1 to GL
+ LS2 (locking-shift-2) none ESC 'n' invoke G2 into GL
+ LS3 (locking-shift-3) none ESC 'o' invoke G3 into GL
+ SS2 (single-shift-2) 0x8E ESC 'N' invoke G2 into GL
+ SS3 (single-shift-3) 0x8F ESC 'O' invoke G3 into GL
+ ----------------------------------------------------------------------
+ The first four are for locking-shift. Control characters for these
+ functions are defined by macros ISO_CODE_XXX in `coding.h'.
+
+ Designations are done by the following escape sequences.
+ ----------------------------------------------------------------------
+ escape sequence description
+ ----------------------------------------------------------------------
+ ESC '(' <F> designate DIMENSION1_CHARS94<F> to G0
+ ESC ')' <F> designate DIMENSION1_CHARS94<F> to G1
+ ESC '*' <F> designate DIMENSION1_CHARS94<F> to G2
+ ESC '+' <F> designate DIMENSION1_CHARS94<F> to G3
+ ESC ',' <F> designate DIMENSION1_CHARS96<F> to G0 (*)
+ ESC '-' <F> designate DIMENSION1_CHARS96<F> to G1
+ ESC '.' <F> designate DIMENSION1_CHARS96<F> to G2
+ ESC '/' <F> designate DIMENSION1_CHARS96<F> to G3
+ ESC '$' '(' <F> designate DIMENSION2_CHARS94<F> to G0 (**)
+ ESC '$' ')' <F> designate DIMENSION2_CHARS94<F> to G1
+ ESC '$' '*' <F> designate DIMENSION2_CHARS94<F> to G2
+ ESC '$' '+' <F> designate DIMENSION2_CHARS94<F> to G3
+ ESC '$' ',' <F> designate DIMENSION2_CHARS96<F> to G0 (*)
+ ESC '$' '-' <F> designate DIMENSION2_CHARS96<F> to G1
+ ESC '$' '.' <F> designate DIMENSION2_CHARS96<F> to G2
+ ESC '$' '/' <F> designate DIMENSION2_CHARS96<F> to G3
+ ----------------------------------------------------------------------
+
+ In this list, "DIMENSION1_CHARS94<F>" means a graphic character set
+ of dimension 1, chars 94, and final character <F>, and etc.
+
+ Note (*): Although these designations are not allowed in ISO2022,
+ Emacs accepts them on decoding, and produces them on encoding
+ CHARS96 character set in a coding system which is characterized as
+ 7-bit environment, non-locking-shift, and non-single-shift.
+
+ Note (**): If <F> is '@', 'A', or 'B', the intermediate character
+ '(' can be omitted. We call this as "short-form" here after.
+
+ Now you may notice that there are a lot of ways for encoding the
+ same multilingual text in ISO2022. Actually, there exist many
+ coding systems such as Compound Text (used in X's inter client
+ communication, ISO-2022-JP (used in Japanese Internet), ISO-2022-KR
+ (used in Korean Internet), EUC (Extended UNIX Code, used in Asian
+ localized platforms), and all of these are variants of ISO2022.
+
+ In addition to the above, Emacs handles two more kinds of escape
+ sequences: ISO6429's direction specification and Emacs' private
+ sequence for specifying character composition.
+
+ ISO6429's direction specification takes the following format:
+ o CSI ']' -- end of the current direction
+ o CSI '0' ']' -- end of the current direction
+ o CSI '1' ']' -- start of left-to-right text
+ o CSI '2' ']' -- start of right-to-left text
+ The control character CSI (0x9B: control sequence introducer) is
+ abbreviated to the escape sequence ESC '[' in 7-bit environment.
+
+ Character composition specification takes the following format:
+ o ESC '0' -- start character composition
+ o ESC '1' -- end character composition
+ Since these are not standard escape sequences of any ISO, the use
+ of them for these meaning is restricted to Emacs only. */
+
+enum iso_code_class_type iso_code_class[256];
+
+/* See the above "GENERAL NOTES on `detect_coding_XXX ()' functions".
+ Check if a text is encoded in ISO2022. If it is, returns an
+ integer in which appropriate flag bits any of:
+ CODING_CATEGORY_MASK_ISO_7
+ CODING_CATEGORY_MASK_ISO_8_1
+ CODING_CATEGORY_MASK_ISO_8_2
+ CODING_CATEGORY_MASK_ISO_ELSE
+ are set. If a code which should never appear in ISO2022 is found,
+ returns 0. */
+
+int
+detect_coding_iso2022 (src, src_end)
+ unsigned char *src, *src_end;
+{
+ unsigned char graphic_register[4];
+ unsigned char c, esc_cntl;
+ int mask = (CODING_CATEGORY_MASK_ISO_7
+ | CODING_CATEGORY_MASK_ISO_8_1
+ | CODING_CATEGORY_MASK_ISO_8_2);
+ /* We may look ahead maximum 3 bytes. */
+ unsigned char *adjusted_src_end = src_end - 3;
+ int i;
+
+ for (i = 0; i < 4; i++)
+ graphic_register[i] = CHARSET_ASCII;
+
+ while (src < adjusted_src_end)
+ {
+ c = *src++;
+ switch (c)
+ {
+ case ISO_CODE_ESC:
+ if (src >= adjusted_src_end)
+ break;
+ c = *src++;
+ if (c == '$')
+ {
+ /* Designation of 2-byte character set. */
+ if (src >= adjusted_src_end)
+ break;
+ c = *src++;
+ }
+ if ((c >= ')' && c <= '+') || (c >= '-' && c <= '/'))
+ /* Designation to graphic register 1, 2, or 3. */
+ mask &= ~CODING_CATEGORY_MASK_ISO_7;
+ else if (c == 'N' || c == 'O' || c == 'n' || c == 'o')
+ return CODING_CATEGORY_MASK_ISO_ELSE;
+ break;
+
+ case ISO_CODE_SI:
+ case ISO_CODE_SO:
+ return CODING_CATEGORY_MASK_ISO_ELSE;
+
+ case ISO_CODE_CSI:
+ case ISO_CODE_SS2:
+ case ISO_CODE_SS3:
+ mask &= ~CODING_CATEGORY_MASK_ISO_7;
+ break;
+
+ default:
+ if (c < 0x80)
+ break;
+ else if (c < 0xA0)
+ return 0;
+ else
+ {
+ int count = 1;
+
+ mask &= ~CODING_CATEGORY_MASK_ISO_7;
+ while (src < adjusted_src_end && *src >= 0xA0)
+ count++, src++;
+ if (count & 1 && src < adjusted_src_end)
+ mask &= ~CODING_CATEGORY_MASK_ISO_8_2;
+ }
+ break;
+ }
+ }
+
+ return mask;
+}
+
+/* Decode a character of which charset is CHARSET and the 1st position
+ code is C1. If dimension of CHARSET 2, the 2nd position code is
+ fetched from SRC and set to C2. If CHARSET is negative, it means
+ that we are decoding ill formed text, and what we can do is just to
+ read C1 as is. */
+
+#define DECODE_ISO_CHARACTER(charset, c1) \
+ do { \
+ if ((charset) >= 0 && CHARSET_DIMENSION (charset) == 2) \
+ ONE_MORE_BYTE (c2); \
+ if (COMPOSING_HEAD_P (coding->composing)) \
+ { \
+ *dst++ = LEADING_CODE_COMPOSITION; \
+ if (COMPOSING_WITH_RULE_P (coding->composing)) \
+ /* To tell composition rules are embeded. */ \
+ *dst++ = 0xFF; \
+ coding->composing += 2; \
+ } \
+ if ((charset) < 0) \
+ *dst++ = c1; \
+ else if ((charset) == CHARSET_ASCII) \
+ DECODE_CHARACTER_ASCII (c1); \
+ else if (CHARSET_DIMENSION (charset) == 1) \
+ DECODE_CHARACTER_DIMENSION1 (charset, c1); \
+ else \
+ DECODE_CHARACTER_DIMENSION2 (charset, c1, c2); \
+ if (COMPOSING_WITH_RULE_P (coding->composing)) \
+ /* To tell a composition rule follows. */ \
+ coding->composing = COMPOSING_WITH_RULE_RULE; \
+ } while (0)
+
+/* Set designation state into CODING. */
+#define DECODE_DESIGNATION(reg, dimension, chars, final_char) \
+ do { \
+ int charset = ISO_CHARSET_TABLE (dimension, chars, final_char); \
+ Lisp_Object temp \
+ = Fassq (CHARSET_SYMBOL (charset), Valternate_charset_table); \
+ if (! NILP (temp)) \
+ charset = get_charset_id (XCONS (temp)->cdr); \
+ if (charset >= 0) \
+ { \
+ if (coding->direction == 1 \
+ && CHARSET_REVERSE_CHARSET (charset) >= 0) \
+ charset = CHARSET_REVERSE_CHARSET (charset); \
+ CODING_SPEC_ISO_DESIGNATION (coding, reg) = charset; \
+ } \
+ } while (0)
+
+/* See the above "GENERAL NOTES on `decode_coding_XXX ()' functions". */
+
+int
+decode_coding_iso2022 (coding, source, destination,
+ src_bytes, dst_bytes, consumed)
+ struct coding_system *coding;
+ unsigned char *source, *destination;
+ int src_bytes, dst_bytes;
+ int *consumed;
+{
+ unsigned char *src = source;
+ unsigned char *src_end = source + src_bytes;
+ unsigned char *dst = destination;
+ unsigned char *dst_end = destination + dst_bytes;
+ /* Since the maximum bytes produced by each loop is 7, we subtract 6
+ from DST_END to assure that overflow checking is necessary only
+ at the head of loop. */
+ unsigned char *adjusted_dst_end = dst_end - 6;
+ int charset;
+ /* Charsets invoked to graphic plane 0 and 1 respectively. */
+ int charset0 = CODING_SPEC_ISO_PLANE_CHARSET (coding, 0);
+ int charset1 = CODING_SPEC_ISO_PLANE_CHARSET (coding, 1);
+
+ while (src < src_end && dst < adjusted_dst_end)
+ {
+ /* SRC_BASE remembers the start position in source in each loop.
+ The loop will be exited when there's not enough source text
+ to analyze long escape sequence or 2-byte code (within macros
+ ONE_MORE_BYTE or TWO_MORE_BYTES). In that case, SRC is reset
+ to SRC_BASE before exiting. */
+ unsigned char *src_base = src;
+ unsigned char c1 = *src++, c2, cmprule;
+
+ switch (iso_code_class [c1])
+ {
+ case ISO_0x20_or_0x7F:
+ if (!coding->composing
+ && (charset0 < 0 || CHARSET_CHARS (charset0) == 94))
+ {
+ /* This is SPACE or DEL. */
+ *dst++ = c1;
+ break;
+ }
+ /* This is a graphic character, we fall down ... */
+
+ case ISO_graphic_plane_0:
+ if (coding->composing == COMPOSING_WITH_RULE_RULE)
+ {
+ /* This is a composition rule. */
+ *dst++ = c1 | 0x80;
+ coding->composing = COMPOSING_WITH_RULE_TAIL;
+ }
+ else
+ DECODE_ISO_CHARACTER (charset0, c1);
+ break;
+
+ case ISO_0xA0_or_0xFF:
+ if (charset1 < 0 || CHARSET_CHARS (charset1) == 94)
+ {
+ /* Invalid code. */
+ *dst++ = c1;
+ break;
+ }
+ /* This is a graphic character, we fall down ... */
+
+ case ISO_graphic_plane_1:
+ DECODE_ISO_CHARACTER (charset1, c1);
+ break;
+
+ case ISO_control_code:
+ /* All ISO2022 control characters in this class have the
+ same representation in Emacs internal format. */
+ *dst++ = c1;
+ break;
+
+ case ISO_carriage_return:
+ if (coding->eol_type == CODING_EOL_CR)
+ {
+ *dst++ = '\n';
+ }
+ else if (coding->eol_type == CODING_EOL_CRLF)
+ {
+ ONE_MORE_BYTE (c1);
+ if (c1 == ISO_CODE_LF)
+ *dst++ = '\n';
+ else
+ {
+ src--;
+ *dst++ = c1;
+ }
+ }
+ else
+ {
+ *dst++ = c1;
+ }
+ break;
+
+ case ISO_shift_out:
+ CODING_SPEC_ISO_INVOCATION (coding, 0) = 1;
+ charset0 = CODING_SPEC_ISO_PLANE_CHARSET (coding, 0);
+ break;
+
+ case ISO_shift_in:
+ CODING_SPEC_ISO_INVOCATION (coding, 0) = 0;
+ charset0 = CODING_SPEC_ISO_PLANE_CHARSET (coding, 0);
+ break;
+
+ case ISO_single_shift_2_7:
+ case ISO_single_shift_2:
+ /* SS2 is handled as an escape sequence of ESC 'N' */
+ c1 = 'N';
+ goto label_escape_sequence;
+
+ case ISO_single_shift_3:
+ /* SS2 is handled as an escape sequence of ESC 'O' */
+ c1 = 'O';
+ goto label_escape_sequence;
+
+ case ISO_control_sequence_introducer:
+ /* CSI is handled as an escape sequence of ESC '[' ... */
+ c1 = '[';
+ goto label_escape_sequence;
+
+ case ISO_escape:
+ ONE_MORE_BYTE (c1);
+ label_escape_sequence:
+ /* Escape sequences handled by Emacs are invocation,
+ designation, direction specification, and character
+ composition specification. */
+ switch (c1)
+ {
+ case '&': /* revision of following character set */
+ ONE_MORE_BYTE (c1);
+ if (!(c1 >= '@' && c1 <= '~'))
+ {
+ goto label_invalid_escape_sequence;
+ }
+ ONE_MORE_BYTE (c1);
+ if (c1 != ISO_CODE_ESC)
+ {
+ goto label_invalid_escape_sequence;
+ }
+ ONE_MORE_BYTE (c1);
+ goto label_escape_sequence;
+
+ case '$': /* designation of 2-byte character set */
+ ONE_MORE_BYTE (c1);
+ if (c1 >= '@' && c1 <= 'B')
+ { /* designation of JISX0208.1978, GB2312.1980,
+ or JISX0208.1980 */
+ DECODE_DESIGNATION (0, 2, 94, c1);
+ }
+ else if (c1 >= 0x28 && c1 <= 0x2B)
+ { /* designation of DIMENSION2_CHARS94 character set */
+ ONE_MORE_BYTE (c2);
+ DECODE_DESIGNATION (c1 - 0x28, 2, 94, c2);
+ }
+ else if (c1 >= 0x2C && c1 <= 0x2F)
+ { /* designation of DIMENSION2_CHARS96 character set */
+ ONE_MORE_BYTE (c2);
+ DECODE_DESIGNATION (c1 - 0x2C, 2, 96, c2);
+ }
+ else
+ {
+ goto label_invalid_escape_sequence;
+ }
+ break;
+
+ case 'n': /* invocation of locking-shift-2 */
+ CODING_SPEC_ISO_INVOCATION (coding, 0) = 2;
+ break;
+
+ case 'o': /* invocation of locking-shift-3 */
+ CODING_SPEC_ISO_INVOCATION (coding, 0) = 3;
+ break;
+
+ case 'N': /* invocation of single-shift-2 */
+ ONE_MORE_BYTE (c1);
+ charset = CODING_SPEC_ISO_DESIGNATION (coding, 2);
+ DECODE_ISO_CHARACTER (charset, c1);
+ break;
+
+ case 'O': /* invocation of single-shift-3 */
+ ONE_MORE_BYTE (c1);
+ charset = CODING_SPEC_ISO_DESIGNATION (coding, 3);
+ DECODE_ISO_CHARACTER (charset, c1);
+ break;
+
+ case '0': /* start composing without embeded rules */
+ coding->composing = COMPOSING_NO_RULE_HEAD;
+ break;
+
+ case '1': /* end composing */
+ coding->composing = COMPOSING_NO;
+ break;
+
+ case '2': /* start composing with embeded rules */
+ coding->composing = COMPOSING_WITH_RULE_HEAD;
+ break;
+
+ case '[': /* specification of direction */
+ /* For the moment, nested direction is not supported.
+ So, the value of `coding->direction' is 0 or 1: 0
+ means left-to-right, 1 means right-to-left. */
+ ONE_MORE_BYTE (c1);
+ switch (c1)
+ {
+ case ']': /* end of the current direction */
+ coding->direction = 0;
+
+ case '0': /* end of the current direction */
+ case '1': /* start of left-to-right direction */
+ ONE_MORE_BYTE (c1);
+ if (c1 == ']')
+ coding->direction = 0;
+ else
+ goto label_invalid_escape_sequence;
+ break;
+
+ case '2': /* start of right-to-left direction */
+ ONE_MORE_BYTE (c1);
+ if (c1 == ']')
+ coding->direction= 1;
+ else
+ goto label_invalid_escape_sequence;
+ break;
+
+ default:
+ goto label_invalid_escape_sequence;
+ }
+ break;
+
+ default:
+ if (c1 >= 0x28 && c1 <= 0x2B)
+ { /* designation of DIMENSION1_CHARS94 character set */
+ ONE_MORE_BYTE (c2);
+ DECODE_DESIGNATION (c1 - 0x28, 1, 94, c2);
+ }
+ else if (c1 >= 0x2C && c1 <= 0x2F)
+ { /* designation of DIMENSION1_CHARS96 character set */
+ ONE_MORE_BYTE (c2);
+ DECODE_DESIGNATION (c1 - 0x2C, 1, 96, c2);
+ }
+ else
+ {
+ goto label_invalid_escape_sequence;
+ }
+ }
+ /* We must update these variables now. */
+ charset0 = CODING_SPEC_ISO_PLANE_CHARSET (coding, 0);
+ charset1 = CODING_SPEC_ISO_PLANE_CHARSET (coding, 1);
+ break;
+
+ label_invalid_escape_sequence:
+ {
+ int length = src - src_base;
+
+ bcopy (src_base, dst, length);
+ dst += length;
+ }
+ }
+ continue;
+
+ label_end_of_loop:
+ coding->carryover_size = src - src_base;
+ bcopy (src_base, coding->carryover, coding->carryover_size);
+ src = src_base;
+ break;
+ }
+
+ /* If this is the last block of the text to be decoded, we had
+ better just flush out all remaining codes in the text although
+ they are not valid characters. */
+ if (coding->last_block)
+ {
+ bcopy (src, dst, src_end - src);
+ dst += (src_end - src);
+ src = src_end;
+ }
+ *consumed = src - source;
+ return dst - destination;
+}
+
+/* ISO2022 encoding staffs. */
+
+/*
+ It is not enough to say just "ISO2022" on encoding, but we have to
+ specify more details. In Emacs, each coding-system of ISO2022
+ variant has the following specifications:
+ 1. Initial designation to G0 thru G3.
+ 2. Allows short-form designation?
+ 3. ASCII should be designated to G0 before control characters?
+ 4. ASCII should be designated to G0 at end of line?
+ 5. 7-bit environment or 8-bit environment?
+ 6. Use locking-shift?
+ 7. Use Single-shift?
+ And the following two are only for Japanese:
+ 8. Use ASCII in place of JIS0201-1976-Roman?
+ 9. Use JISX0208-1983 in place of JISX0208-1978?
+ These specifications are encoded in `coding->flags' as flag bits
+ defined by macros CODING_FLAG_ISO_XXX. See `coding.h' for more
+ detail.
+*/
+
+/* Produce codes (escape sequence) for designating CHARSET to graphic
+ register REG. If <final-char> of CHARSET is '@', 'A', or 'B' and
+ the coding system CODING allows, produce designation sequence of
+ short-form. */
+
+#define ENCODE_DESIGNATION(charset, reg, coding) \
+ do { \
+ unsigned char final_char = CHARSET_ISO_FINAL_CHAR (charset); \
+ char *intermediate_char_94 = "()*+"; \
+ char *intermediate_char_96 = ",-./"; \
+ Lisp_Object temp \
+ = Fassq (make_number (charset), Vcharset_revision_alist); \
+ if (! NILP (temp)) \
+ { \
+ *dst++ = ISO_CODE_ESC; \
+ *dst++ = '&'; \
+ *dst++ = XINT (XCONS (temp)->cdr) + '@'; \
+ } \
+ *dst++ = ISO_CODE_ESC; \
+ if (CHARSET_DIMENSION (charset) == 1) \
+ { \
+ if (CHARSET_CHARS (charset) == 94) \
+ *dst++ = (unsigned char) (intermediate_char_94[reg]); \
+ else \
+ *dst++ = (unsigned char) (intermediate_char_96[reg]); \
+ } \
+ else \
+ { \
+ *dst++ = '$'; \
+ if (CHARSET_CHARS (charset) == 94) \
+ { \
+ if (! (coding->flags & CODING_FLAG_ISO_SHORT_FORM) \
+ || reg != 0 \
+ || final_char < '@' || final_char > 'B') \
+ *dst++ = (unsigned char) (intermediate_char_94[reg]); \
+ } \
+ else \
+ *dst++ = (unsigned char) (intermediate_char_96[reg]); \
+ } \
+ *dst++ = final_char; \
+ CODING_SPEC_ISO_DESIGNATION (coding, reg) = charset; \
+ } while (0)
+
+/* The following two macros produce codes (control character or escape
+ sequence) for ISO2022 single-shift functions (single-shift-2 and
+ single-shift-3). */
+
+#define ENCODE_SINGLE_SHIFT_2 \
+ do { \
+ if (coding->flags & CODING_FLAG_ISO_SEVEN_BITS) \
+ *dst++ = ISO_CODE_ESC, *dst++ = 'N'; \
+ else \
+ *dst++ = ISO_CODE_SS2; \
+ CODING_SPEC_ISO_SINGLE_SHIFTING (coding) = 1; \
+ } while (0)
+
+#define ENCODE_SINGLE_SHIFT_3 \
+ do { \
+ if (coding->flags & CODING_FLAG_ISO_SEVEN_BITS) \
+ *dst++ = ISO_CODE_ESC, *dst++ = 'O'; \
+ else \
+ *dst++ = ISO_CODE_SS3; \
+ CODING_SPEC_ISO_SINGLE_SHIFTING (coding) = 1; \
+ } while (0)
+
+/* The following four macros produce codes (control character or
+ escape sequence) for ISO2022 locking-shift functions (shift-in,
+ shift-out, locking-shift-2, and locking-shift-3). */
+
+#define ENCODE_SHIFT_IN \
+ do { \
+ *dst++ = ISO_CODE_SI; \
+ CODING_SPEC_ISO_INVOCATION (coding, 0) = 0; \
+ } while (0)
+
+#define ENCODE_SHIFT_OUT \
+ do { \
+ *dst++ = ISO_CODE_SO; \
+ CODING_SPEC_ISO_INVOCATION (coding, 0) = 1; \
+ } while (0)
+
+#define ENCODE_LOCKING_SHIFT_2 \
+ do { \
+ *dst++ = ISO_CODE_ESC, *dst++ = 'n'; \
+ CODING_SPEC_ISO_INVOCATION (coding, 0) = 2; \
+ } while (0)
+
+#define ENCODE_LOCKING_SHIFT_3 \
+ do { \
+ *dst++ = ISO_CODE_ESC, *dst++ = 'o'; \
+ CODING_SPEC_ISO_INVOCATION (coding, 0) = 3; \
+ } while (0)
+
+/* Produce codes for a DIMENSION1 character of which character set is
+ CHARSET and position-code is C1. Designation and invocation
+ sequences are also produced in advance if necessary. */
+
+
+#define ENCODE_ISO_CHARACTER_DIMENSION1(charset, c1) \
+ do { \
+ if (CODING_SPEC_ISO_SINGLE_SHIFTING (coding)) \
+ { \
+ if (coding->flags & CODING_FLAG_ISO_SEVEN_BITS) \
+ *dst++ = c1 & 0x7F; \
+ else \
+ *dst++ = c1 | 0x80; \
+ CODING_SPEC_ISO_SINGLE_SHIFTING (coding) = 0; \
+ break; \
+ } \
+ else if (charset == CODING_SPEC_ISO_PLANE_CHARSET (coding, 0)) \
+ { \
+ *dst++ = c1 & 0x7F; \
+ break; \
+ } \
+ else if (charset == CODING_SPEC_ISO_PLANE_CHARSET (coding, 1)) \
+ { \
+ *dst++ = c1 | 0x80; \
+ break; \
+ } \
+ else \
+ /* Since CHARSET is not yet invoked to any graphic planes, we \
+ must invoke it, or, at first, designate it to some graphic \
+ register. Then repeat the loop to actually produce the \
+ character. */ \
+ dst = encode_invocation_designation (charset, coding, dst); \
+ } while (1)
+
+/* Produce codes for a DIMENSION2 character of which character set is
+ CHARSET and position-codes are C1 and C2. Designation and
+ invocation codes are also produced in advance if necessary. */
+
+#define ENCODE_ISO_CHARACTER_DIMENSION2(charset, c1, c2) \
+ do { \
+ if (CODING_SPEC_ISO_SINGLE_SHIFTING (coding)) \
+ { \
+ if (coding->flags & CODING_FLAG_ISO_SEVEN_BITS) \
+ *dst++ = c1 & 0x7F, *dst++ = c2 & 0x7F; \
+ else \
+ *dst++ = c1 | 0x80, *dst++ = c2 | 0x80; \
+ CODING_SPEC_ISO_SINGLE_SHIFTING (coding) = 0; \
+ break; \
+ } \
+ else if (charset == CODING_SPEC_ISO_PLANE_CHARSET (coding, 0)) \
+ { \
+ *dst++ = c1 & 0x7F, *dst++= c2 & 0x7F; \
+ break; \
+ } \
+ else if (charset == CODING_SPEC_ISO_PLANE_CHARSET (coding, 1)) \
+ { \
+ *dst++ = c1 | 0x80, *dst++= c2 | 0x80; \
+ break; \
+ } \
+ else \
+ /* Since CHARSET is not yet invoked to any graphic planes, we \
+ must invoke it, or, at first, designate it to some graphic \
+ register. Then repeat the loop to actually produce the \
+ character. */ \
+ dst = encode_invocation_designation (charset, coding, dst); \
+ } while (1)
+
+/* Produce designation and invocation codes at a place pointed by DST
+ to use CHARSET. The element `spec.iso2022' of *CODING is updated.
+ Return new DST. */
+
+unsigned char *
+encode_invocation_designation (charset, coding, dst)
+ int charset;
+ struct coding_system *coding;
+ unsigned char *dst;
+{
+ int reg; /* graphic register number */
+
+ /* At first, check designations. */
+ for (reg = 0; reg < 4; reg++)
+ if (charset == CODING_SPEC_ISO_DESIGNATION (coding, reg))
+ break;
+
+ if (reg >= 4)
+ {
+ /* CHARSET is not yet designated to any graphic registers. */
+ /* At first check the requested designation. */
+ reg = CODING_SPEC_ISO_REQUESTED_DESIGNATION (coding, charset);
+ if (reg < 0)
+ /* Since CHARSET requests no special designation, designate to
+ graphic register 0. */
+ reg = 0;
+
+ ENCODE_DESIGNATION (charset, reg, coding);
+ }
+
+ if (CODING_SPEC_ISO_INVOCATION (coding, 0) != reg
+ && CODING_SPEC_ISO_INVOCATION (coding, 1) != reg)
+ {
+ /* Since the graphic register REG is not invoked to any graphic
+ planes, invoke it to graphic plane 0. */
+ switch (reg)
+ {
+ case 0: /* graphic register 0 */
+ ENCODE_SHIFT_IN;
+ break;
+
+ case 1: /* graphic register 1 */
+ ENCODE_SHIFT_OUT;
+ break;
+
+ case 2: /* graphic register 2 */
+ if (coding->flags & CODING_FLAG_ISO_SINGLE_SHIFT)
+ ENCODE_SINGLE_SHIFT_2;
+ else
+ ENCODE_LOCKING_SHIFT_2;
+ break;
+
+ case 3: /* graphic register 3 */
+ if (coding->flags & CODING_FLAG_ISO_SINGLE_SHIFT)
+ ENCODE_SINGLE_SHIFT_3;
+ else
+ ENCODE_LOCKING_SHIFT_3;
+ break;
+ }
+ }
+ return dst;
+}
+
+/* The following two macros produce codes for indicating composition. */
+#define ENCODE_COMPOSITION_NO_RULE_START *dst++ = ISO_CODE_ESC, *dst++ = '0'
+#define ENCODE_COMPOSITION_WITH_RULE_START *dst++ = ISO_CODE_ESC, *dst++ = '2'
+#define ENCODE_COMPOSITION_END *dst++ = ISO_CODE_ESC, *dst++ = '1'
+
+/* The following three macros produce codes for indicating direction
+ of text. */
+#define ENCODE_CONTROL_SEQUENCE_INTRODUCER \
+ do { \
+ if (coding->flags == CODING_FLAG_ISO_SEVEN_BITS) \
+ *dst++ = ISO_CODE_ESC, *dst++ = '['; \
+ else \
+ *dst++ = ISO_CODE_CSI; \
+ } while (0)
+
+#define ENCODE_DIRECTION_R2L \
+ ENCODE_CONTROL_SEQUENCE_INTRODUCER, *dst++ = '2', *dst++ = ']'
+
+#define ENCODE_DIRECTION_L2R \
+ ENCODE_CONTROL_SEQUENCE_INTRODUCER, *dst++ = '0', *dst++ = ']'
+
+/* Produce codes for designation and invocation to reset the graphic
+ planes and registers to initial state. */
+#define ENCODE_RESET_PLANE_AND_REGISTER(eol) \
+ do { \
+ int reg; \
+ if (CODING_SPEC_ISO_INVOCATION (coding, 0) != 0) \
+ ENCODE_SHIFT_IN; \
+ for (reg = 0; reg < 4; reg++) \
+ { \
+ if (CODING_SPEC_ISO_INITIAL_DESIGNATION (coding, reg) < 0) \
+ { \
+ if (eol) CODING_SPEC_ISO_DESIGNATION (coding, reg) = -1; \
+ } \
+ else if (CODING_SPEC_ISO_DESIGNATION (coding, reg) \
+ != CODING_SPEC_ISO_INITIAL_DESIGNATION (coding, reg)) \
+ ENCODE_DESIGNATION \
+ (CODING_SPEC_ISO_INITIAL_DESIGNATION (coding, reg), reg, coding); \
+ } \
+ } while (0)
+
+/* See the above "GENERAL NOTES on `encode_coding_XXX ()' functions". */
+
+int
+encode_coding_iso2022 (coding, source, destination,
+ src_bytes, dst_bytes, consumed)
+ struct coding_system *coding;
+ unsigned char *source, *destination;
+ int src_bytes, dst_bytes;
+ int *consumed;
+{
+ unsigned char *src = source;
+ unsigned char *src_end = source + src_bytes;
+ unsigned char *dst = destination;
+ unsigned char *dst_end = destination + dst_bytes;
+ /* Since the maximum bytes produced by each loop is 6, we subtract 5
+ from DST_END to assure overflow checking is necessary only at the
+ head of loop. */
+ unsigned char *adjusted_dst_end = dst_end - 5;
+
+ while (src < src_end && dst < adjusted_dst_end)
+ {
+ /* SRC_BASE remembers the start position in source in each loop.
+ The loop will be exited when there's not enough source text
+ to analyze multi-byte codes (within macros ONE_MORE_BYTE,
+ TWO_MORE_BYTES, and THREE_MORE_BYTES). In that case, SRC is
+ reset to SRC_BASE before exiting. */
+ unsigned char *src_base = src;
+ unsigned char c1 = *src++, c2, c3, c4;
+ int charset;
+
+ /* If we are seeing a component of a composite character, we are
+ seeing a leading-code specially encoded for composition, or a
+ composition rule if composing with rule. We must set C1
+ to a normal leading-code or an ASCII code. If we are not at
+ a composed character, we must reset the composition state. */
+ if (COMPOSING_P (coding->composing))
+ {
+ if (c1 < 0xA0)
+ {
+ /* We are not in a composite character any longer. */
+ coding->composing = COMPOSING_NO;
+ ENCODE_COMPOSITION_END;
+ }
+ else
+ {
+ if (coding->composing == COMPOSING_WITH_RULE_RULE)
+ {
+ *dst++ = c1 & 0x7F;
+ coding->composing = COMPOSING_WITH_RULE_HEAD;
+ continue;
+ }
+ else if (coding->composing == COMPOSING_WITH_RULE_HEAD)
+ coding->composing = COMPOSING_WITH_RULE_RULE;
+ if (c1 == 0xA0)
+ {
+ /* This is an ASCII component. */
+ ONE_MORE_BYTE (c1);
+ c1 &= 0x7F;
+ }
+ else
+ /* This is a leading-code of non ASCII component. */
+ c1 -= 0x20;
+ }
+ }
+
+ /* Now encode one character. C1 is a control character, an
+ ASCII character, or a leading-code of multi-byte character. */
+ switch (emacs_code_class[c1])
+ {
+ case EMACS_ascii_code:
+ ENCODE_ISO_CHARACTER_DIMENSION1 (CHARSET_ASCII, c1);
+ break;
+
+ case EMACS_control_code:
+ if (coding->flags & CODING_FLAG_ISO_RESET_AT_CNTL)
+ ENCODE_RESET_PLANE_AND_REGISTER (0);
+ *dst++ = c1;
+ break;
+
+ case EMACS_carriage_return_code:
+ if (!coding->selective)
+ {
+ if (coding->flags & CODING_FLAG_ISO_RESET_AT_CNTL)
+ ENCODE_RESET_PLANE_AND_REGISTER (0);
+ *dst++ = c1;
+ break;
+ }
+ /* fall down to treat '\r' as '\n' ... */
+
+ case EMACS_linefeed_code:
+ if (coding->flags & CODING_FLAG_ISO_RESET_AT_EOL)
+ ENCODE_RESET_PLANE_AND_REGISTER (1);
+ if (coding->eol_type == CODING_EOL_LF
+ || coding->eol_type == CODING_EOL_AUTOMATIC)
+ *dst++ = ISO_CODE_LF;
+ else if (coding->eol_type == CODING_EOL_CRLF)
+ *dst++ = ISO_CODE_CR, *dst++ = ISO_CODE_LF;
+ else
+ *dst++ = ISO_CODE_CR;
+ break;
+
+ case EMACS_leading_code_2:
+ ONE_MORE_BYTE (c2);
+ ENCODE_ISO_CHARACTER_DIMENSION1 (c1, c2);
+ break;
+
+ case EMACS_leading_code_3:
+ TWO_MORE_BYTES (c2, c3);
+ if (c1 < LEADING_CODE_PRIVATE_11)
+ ENCODE_ISO_CHARACTER_DIMENSION2 (c1, c2, c3);
+ else
+ ENCODE_ISO_CHARACTER_DIMENSION1 (c2, c3);
+ break;
+
+ case EMACS_leading_code_4:
+ THREE_MORE_BYTES (c2, c3, c4);
+ ENCODE_ISO_CHARACTER_DIMENSION2 (c2, c3, c4);
+ break;
+
+ case EMACS_leading_code_composition:
+ ONE_MORE_BYTE (c1);
+ if (c1 == 0xFF)
+ {
+ coding->composing = COMPOSING_WITH_RULE_HEAD;
+ ENCODE_COMPOSITION_WITH_RULE_START;
+ }
+ else
+ {
+ /* Rewind one byte because it is a character code of
+ composition elements. */
+ src--;
+ coding->composing = COMPOSING_NO_RULE_HEAD;
+ ENCODE_COMPOSITION_NO_RULE_START;
+ }
+ break;
+
+ case EMACS_invalid_code:
+ *dst++ = c1;
+ break;
+ }
+ continue;
+ label_end_of_loop:
+ coding->carryover_size = src - src_base;
+ bcopy (src_base, coding->carryover, coding->carryover_size);
+ src = src_base;
+ break;
+ }
+
+ /* If this is the last block of the text to be encoded, we must
+ reset the state of graphic planes and registers to initial one.
+ In addition, we had better just flush out all remaining codes in
+ the text although they are not valid characters. */
+ if (coding->last_block)
+ {
+ ENCODE_RESET_PLANE_AND_REGISTER (1);
+ bcopy(src, dst, src_end - src);
+ dst += (src_end - src);
+ src = src_end;
+ }
+ *consumed = src - source;
+ return dst - destination;
+}
+
+\f
+/*** 4. SJIS and BIG5 handlers ***/
+
+/* Although SJIS and BIG5 are not ISO's coding system, They are used
+ quite widely. So, for the moment, Emacs supports them in the bare
+ C code. But, in the future, they may be supported only by CCL. */
+
+/* SJIS is a coding system encoding three character sets: ASCII, right
+ half of JISX0201-Kana, and JISX0208. An ASCII character is encoded
+ as is. A character of charset katakana-jisx0201 is encoded by
+ "position-code + 0x80". A character of charset japanese-jisx0208
+ is encoded in 2-byte but two position-codes are divided and shifted
+ so that it fit in the range below.
+
+ --- CODE RANGE of SJIS ---
+ (character set) (range)
+ ASCII 0x00 .. 0x7F
+ KATAKANA-JISX0201 0xA0 .. 0xDF
+ JISX0208 (1st byte) 0x80 .. 0x9F and 0xE0 .. 0xFF
+ (2nd byte) 0x40 .. 0xFF
+ -------------------------------
+
+*/
+
+/* BIG5 is a coding system encoding two character sets: ASCII and
+ Big5. An ASCII character is encoded as is. Big5 is a two-byte
+ character set and is encoded in two-byte.
+
+ --- CODE RANGE of BIG5 ---
+ (character set) (range)
+ ASCII 0x00 .. 0x7F
+ Big5 (1st byte) 0xA1 .. 0xFE
+ (2nd byte) 0x40 .. 0x7E and 0xA1 .. 0xFE
+ --------------------------
+
+ Since the number of characters in Big5 is larger than maximum
+ characters in Emacs' charset (96x96), it can't be handled as one
+ charset. So, in Emacs, Big5 is divided into two: `charset-big5-1'
+ and `charset-big5-2'. Both are DIMENSION2 and CHARS94. The former
+ contains frequently used characters and the latter contains less
+ frequently used characters. */
+
+/* Macros to decode or encode a character of Big5 in BIG5. B1 and B2
+ are the 1st and 2nd position-codes of Big5 in BIG5 coding system.
+ C1 and C2 are the 1st and 2nd position-codes of of Emacs' internal
+ format. CHARSET is `charset_big5_1' or `charset_big5_2'. */
+
+/* Number of Big5 characters which have the same code in 1st byte. */
+#define BIG5_SAME_ROW (0xFF - 0xA1 + 0x7F - 0x40)
+
+#define DECODE_BIG5(b1, b2, charset, c1, c2) \
+ do { \
+ unsigned int temp \
+ = (b1 - 0xA1) * BIG5_SAME_ROW + b2 - (b2 < 0x7F ? 0x40 : 0x62); \
+ if (b1 < 0xC9) \
+ charset = charset_big5_1; \
+ else \
+ { \
+ charset = charset_big5_2; \
+ temp -= (0xC9 - 0xA1) * BIG5_SAME_ROW; \
+ } \
+ c1 = temp / (0xFF - 0xA1) + 0x21; \
+ c2 = temp % (0xFF - 0xA1) + 0x21; \
+ } while (0)
+
+#define ENCODE_BIG5(charset, c1, c2, b1, b2) \
+ do { \
+ unsigned int temp = (c1 - 0x21) * (0xFF - 0xA1) + (c2 - 0x21); \
+ if (charset == charset_big5_2) \
+ temp += BIG5_SAME_ROW * (0xC9 - 0xA1); \
+ b1 = temp / BIG5_SAME_ROW + 0xA1; \
+ b2 = temp % BIG5_SAME_ROW; \
+ b2 += b2 < 0x3F ? 0x40 : 0x62; \
+ } while (0)
+
+/* See the above "GENERAL NOTES on `detect_coding_XXX ()' functions".
+ Check if a text is encoded in SJIS. If it is, return
+ CODING_CATEGORY_MASK_SJIS, else return 0. */
+
+int
+detect_coding_sjis (src, src_end)
+ unsigned char *src, *src_end;
+{
+ unsigned char c;
+
+ while (src < src_end)
+ {
+ c = *src++;
+ if (c == ISO_CODE_ESC || c == ISO_CODE_SI || c == ISO_CODE_SO)
+ return 0;
+ if ((c >= 0x80 && c < 0xA0) || c >= 0xE0)
+ {
+ if (src < src_end && *src++ < 0x40)
+ return 0;
+ }
+ }
+ return CODING_CATEGORY_MASK_SJIS;
+}
+
+/* See the above "GENERAL NOTES on `detect_coding_XXX ()' functions".
+ Check if a text is encoded in BIG5. If it is, return
+ CODING_CATEGORY_MASK_BIG5, else return 0. */
+
+int
+detect_coding_big5 (src, src_end)
+ unsigned char *src, *src_end;
+{
+ unsigned char c;
+
+ while (src < src_end)
+ {
+ c = *src++;
+ if (c == ISO_CODE_ESC || c == ISO_CODE_SI || c == ISO_CODE_SO)
+ return 0;
+ if (c >= 0xA1)
+ {
+ if (src >= src_end)
+ break;
+ c = *src++;
+ if (c < 0x40 || (c >= 0x7F && c <= 0xA0))
+ return 0;
+ }
+ }
+ return CODING_CATEGORY_MASK_BIG5;
+}
+
+/* See the above "GENERAL NOTES on `decode_coding_XXX ()' functions".
+ If SJIS_P is 1, decode SJIS text, else decode BIG5 test. */
+
+int
+decode_coding_sjis_big5 (coding, source, destination,
+ src_bytes, dst_bytes, consumed, sjis_p)
+ struct coding_system *coding;
+ unsigned char *source, *destination;
+ int src_bytes, dst_bytes;
+ int *consumed;
+ int sjis_p;
+{
+ unsigned char *src = source;
+ unsigned char *src_end = source + src_bytes;
+ unsigned char *dst = destination;
+ unsigned char *dst_end = destination + dst_bytes;
+ /* Since the maximum bytes produced by each loop is 4, we subtract 3
+ from DST_END to assure overflow checking is necessary only at the
+ head of loop. */
+ unsigned char *adjusted_dst_end = dst_end - 3;
+
+ while (src < src_end && dst < adjusted_dst_end)
+ {
+ /* SRC_BASE remembers the start position in source in each loop.
+ The loop will be exited when there's not enough source text
+ to analyze two-byte character (within macro ONE_MORE_BYTE).
+ In that case, SRC is reset to SRC_BASE before exiting. */
+ unsigned char *src_base = src;
+ unsigned char c1 = *src++, c2, c3, c4;
+
+ if (c1 == '\r')
+ {
+ if (coding->eol_type == CODING_EOL_CRLF)
+ {
+ ONE_MORE_BYTE (c2);
+ if (c2 == '\n')
+ *dst++ = c2;
+ else
+ /* To process C2 again, SRC is subtracted by 1. */
+ *dst++ = c1, src--;
+ }
+ else
+ *dst++ = c1;
+ }
+ else if (c1 < 0x80)
+ *dst++ = c1;
+ else if (c1 < 0xA0 || c1 >= 0xE0)
+ {
+ /* SJIS -> JISX0208, BIG5 -> Big5 (only if 0xE0 <= c1 < 0xFF) */
+ if (sjis_p)
+ {
+ ONE_MORE_BYTE (c2);
+ DECODE_SJIS (c1, c2, c3, c4);
+ DECODE_CHARACTER_DIMENSION2 (charset_jisx0208, c3, c4);
+ }
+ else if (c1 >= 0xE0 && c1 < 0xFF)
+ {
+ int charset;
+
+ ONE_MORE_BYTE (c2);
+ DECODE_BIG5 (c1, c2, charset, c3, c4);
+ DECODE_CHARACTER_DIMENSION2 (charset, c3, c4);
+ }
+ else /* Invalid code */
+ *dst++ = c1;
+ }
+ else
+ {
+ /* SJIS -> JISX0201-Kana, BIG5 -> Big5 */
+ if (sjis_p)
+ DECODE_CHARACTER_DIMENSION1 (charset_katakana_jisx0201, c1);
+ else
+ {
+ int charset;
+
+ ONE_MORE_BYTE (c2);
+ DECODE_BIG5 (c1, c2, charset, c3, c4);
+ DECODE_CHARACTER_DIMENSION2 (charset, c3, c4);
+ }
+ }
+ continue;
+
+ label_end_of_loop:
+ coding->carryover_size = src - src_base;
+ bcopy (src_base, coding->carryover, coding->carryover_size);
+ src = src_base;
+ break;
+ }
+
+ *consumed = src - source;
+ return dst - destination;
+}
+
+/* See the above "GENERAL NOTES on `encode_coding_XXX ()' functions".
+ This function can encode `charset_ascii', `charset_katakana_jisx0201',
+ `charset_jisx0208', `charset_big5_1', and `charset_big5-2'. We are
+ sure that all these charsets are registered as official charset
+ (i.e. do not have extended leading-codes). Characters of other
+ charsets are produced without any encoding. If SJIS_P is 1, encode
+ SJIS text, else encode BIG5 text. */
+
+int
+encode_coding_sjis_big5 (coding, source, destination,
+ src_bytes, dst_bytes, consumed, sjis_p)
+ struct coding_system *coding;
+ unsigned char *source, *destination;
+ int src_bytes, dst_bytes;
+ int *consumed;
+ int sjis_p;
+{
+ unsigned char *src = source;
+ unsigned char *src_end = source + src_bytes;
+ unsigned char *dst = destination;
+ unsigned char *dst_end = destination + dst_bytes;
+ /* Since the maximum bytes produced by each loop is 2, we subtract 1
+ from DST_END to assure overflow checking is necessary only at the
+ head of loop. */
+ unsigned char *adjusted_dst_end = dst_end - 1;
+
+ while (src < src_end && dst < adjusted_dst_end)
+ {
+ /* SRC_BASE remembers the start position in source in each loop.
+ The loop will be exited when there's not enough source text
+ to analyze multi-byte codes (within macros ONE_MORE_BYTE and
+ TWO_MORE_BYTES). In that case, SRC is reset to SRC_BASE
+ before exiting. */
+ unsigned char *src_base = src;
+ unsigned char c1 = *src++, c2, c3, c4;
+
+ if (coding->composing)
+ {
+ if (c1 == 0xA0)
+ {
+ ONE_MORE_BYTE (c1);
+ c1 &= 0x7F;
+ }
+ else if (c1 >= 0xA0)
+ c1 -= 0x20;
+ else
+ coding->composing = 0;
+ }
+
+ switch (emacs_code_class[c1])
+ {
+ case EMACS_ascii_code:
+ case EMACS_control_code:
+ *dst++ = c1;
+ break;
+
+ case EMACS_carriage_return_code:
+ if (!coding->selective)
+ {
+ *dst++ = c1;
+ break;
+ }
+ /* fall down to treat '\r' as '\n' ... */
+
+ case EMACS_linefeed_code:
+ if (coding->eol_type == CODING_EOL_LF
+ || coding->eol_type == CODING_EOL_AUTOMATIC)
+ *dst++ = '\n';
+ else if (coding->eol_type == CODING_EOL_CRLF)
+ *dst++ = '\r', *dst++ = '\n';
+ else
+ *dst++ = '\r';
+ break;
+
+ case EMACS_leading_code_2:
+ ONE_MORE_BYTE (c2);
+ if (sjis_p && c1 == charset_katakana_jisx0201)
+ *dst++ = c2;
+ else
+ *dst++ = c1, *dst++ = c2;
+ break;
+
+ case EMACS_leading_code_3:
+ TWO_MORE_BYTES (c2, c3);
+ c2 &= 0x7F, c3 &= 0x7F;
+ if (sjis_p && c1 == charset_jisx0208)
+ {
+ unsigned char s1, s2;
+
+ ENCODE_SJIS (c2, c3, s1, s2);
+ *dst++ = s1, *dst++ = s2;
+ }
+ else if (!sjis_p && (c1 == charset_big5_1 || c1 == charset_big5_2))
+ {
+ unsigned char b1, b2;
+
+ ENCODE_BIG5 (c1, c2, c3, b1, b2);
+ *dst++ = b1, *dst++ = b2;
+ }
+ else
+ *dst++ = c1, *dst++ = c2, *dst++ = c3;
+ break;
+
+ case EMACS_leading_code_4:
+ THREE_MORE_BYTES (c2, c3, c4);
+ *dst++ = c1, *dst++ = c2, *dst++ = c3, *dst++ = c4;
+ break;
+
+ case EMACS_leading_code_composition:
+ coding->composing = 1;
+ break;
+
+ default: /* i.e. case EMACS_invalid_code: */
+ *dst++ = c1;
+ }
+ continue;
+
+ label_end_of_loop:
+ coding->carryover_size = src - src_base;
+ bcopy (src_base, coding->carryover, coding->carryover_size);
+ src = src_base;
+ break;
+ }
+
+ *consumed = src - source;
+ return dst - destination;
+}
+
+\f
+/*** 5. End-of-line handlers ***/
+
+/* See the above "GENERAL NOTES on `decode_coding_XXX ()' functions".
+ This function is called only when `coding->eol_type' is
+ CODING_EOL_CRLF or CODING_EOL_CR. */
+
+decode_eol (coding, source, destination, src_bytes, dst_bytes, consumed)
+ struct coding_system *coding;
+ unsigned char *source, *destination;
+ int src_bytes, dst_bytes;
+ int *consumed;
+{
+ unsigned char *src = source;
+ unsigned char *src_end = source + src_bytes;
+ unsigned char *dst = destination;
+ unsigned char *dst_end = destination + dst_bytes;
+ int produced;
+
+ switch (coding->eol_type)
+ {
+ case CODING_EOL_CRLF:
+ {
+ /* Since the maximum bytes produced by each loop is 2, we
+ subtract 1 from DST_END to assure overflow checking is
+ necessary only at the head of loop. */
+ unsigned char *adjusted_dst_end = dst_end - 1;
+
+ while (src < src_end && dst < adjusted_dst_end)
+ {
+ unsigned char *src_base = src;
+ unsigned char c = *src++;
+ if (c == '\r')
+ {
+ ONE_MORE_BYTE (c);
+ if (c != '\n')
+ *dst++ = '\r';
+
+ }
+ else
+ *dst++ = c;
+ continue;
+
+ label_end_of_loop:
+ coding->carryover_size = src - src_base;
+ bcopy (src_base, coding->carryover, coding->carryover_size);
+ src = src_base;
+ break;
+ }
+ *consumed = src - source;
+ produced = dst - destination;
+ break;
+ }
+
+ case CODING_EOL_CR:
+ produced = (src_bytes > dst_bytes) ? dst_bytes : src_bytes;
+ bcopy (source, destination, produced);
+ dst_end = destination + produced;
+ while (dst < dst_end)
+ if (*dst++ == '\r') dst[-1] = '\n';
+ *consumed = produced;
+ break;
+
+ default: /* i.e. case: CODING_EOL_LF */
+ produced = (src_bytes > dst_bytes) ? dst_bytes : src_bytes;
+ bcopy (source, destination, produced);
+ *consumed = produced;
+ break;
+ }
+
+ return produced;
+}
+
+/* See "GENERAL NOTES about `encode_coding_XXX ()' functions". Encode
+ format of end-of-line according to `coding->eol_type'. If
+ `coding->selective' is 1, code '\r' in source text also means
+ end-of-line. */
+
+encode_eol (coding, source, destination, src_bytes, dst_bytes, consumed)
+ struct coding_system *coding;
+ unsigned char *source, *destination;
+ int src_bytes, dst_bytes;
+ int *consumed;
+{
+ unsigned char *src = source;
+ unsigned char *dst = destination;
+ int produced;
+
+ if (src_bytes <= 0)
+ return 0;
+
+ switch (coding->eol_type)
+ {
+ case CODING_EOL_LF:
+ case CODING_EOL_AUTOMATIC:
+ produced = (src_bytes > dst_bytes) ? dst_bytes : src_bytes;
+ bcopy (source, destination, produced);
+ if (coding->selective)
+ {
+ int i = produced;
+ while (i--)
+ if (*dst++ == '\r') dst[-1] = '\n';
+ }
+ *consumed = produced;
+
+ case CODING_EOL_CRLF:
+ {
+ unsigned char c;
+ unsigned char *src_end = source + src_bytes;
+ unsigned char *dst_end = destination + dst_bytes;
+ /* Since the maximum bytes produced by each loop is 2, we
+ subtract 1 from DST_END to assure overflow checking is
+ necessary only at the head of loop. */
+ unsigned char *adjusted_dst_end = dst_end - 1;
+
+ while (src < src_end && dst < adjusted_dst_end)
+ {
+ c = *src++;
+ if (c == '\n' || (c == '\r' && coding->selective))
+ *dst++ = '\r', *dst++ = '\n';
+ else
+ *dst++ = c;
+ }
+ produced = dst - destination;
+ *consumed = src - source;
+ break;
+ }
+
+ default: /* i.e. case CODING_EOL_CR: */
+ produced = (src_bytes > dst_bytes) ? dst_bytes : src_bytes;
+ bcopy (source, destination, produced);
+ {
+ int i = produced;
+ while (i--)
+ if (*dst++ == '\n') dst[-1] = '\r';
+ }
+ *consumed = produced;
+ }
+
+ return produced;
+}
+
+\f
+/*** 6. C library functions ***/
+
+/* In Emacs Lisp, coding system is represented by a Lisp symbol which
+ has a property `coding-system'. The value of this property is a
+ vector of length 5 (called as coding-vector). Among elements of
+ this vector, the first (element[0]) and the fifth (element[4])
+ carry important information for decoding/encoding. Before
+ decoding/encoding, this information should be set in fields of a
+ structure of type `coding_system'.
+
+ A value of property `coding-system' can be a symbol of another
+ subsidiary coding-system. In that case, Emacs gets coding-vector
+ from that symbol.
+
+ `element[0]' contains information to be set in `coding->type'. The
+ value and its meaning is as follows:
+
+ 0 -- coding_system_internal
+ 1 -- coding_system_sjis
+ 2 -- coding_system_iso2022
+ 3 -- coding_system_big5
+ 4 -- coding_system_ccl
+ nil -- coding_system_no_conversion
+ t -- coding_system_automatic
+
+ `element[4]' contains information to be set in `coding->flags' and
+ `coding->spec'. The meaning varies by `coding->type'.
+
+ If `coding->type' is `coding_type_iso2022', element[4] is a vector
+ of length 32 (of which the first 13 sub-elements are used now).
+ Meanings of these sub-elements are:
+
+ sub-element[N] where N is 0 through 3: to be set in `coding->spec.iso2022'
+ If the value is an integer of valid charset, the charset is
+ assumed to be designated to graphic register N initially.
+
+ If the value is minus, it is a minus value of charset which
+ reserves graphic register N, which means that the charset is
+ not designated initially but should be designated to graphic
+ register N just before encoding a character in that charset.
+
+ If the value is nil, graphic register N is never used on
+ encoding.
+
+ sub-element[N] where N is 4 through 11: to be set in `coding->flags'
+ Each value takes t or nil. See the section ISO2022 of
+ `coding.h' for more information.
+
+ If `coding->type' is `coding_type_big5', element[4] is t to denote
+ BIG5-ETen or nil to denote BIG5-HKU.
+
+ If `coding->type' takes the other value, element[4] is ignored.
+
+ Emacs Lisp's coding system also carries information about format of
+ end-of-line in a value of property `eol-type'. If the value is
+ integer, 0 means CODING_EOL_LF, 1 means CODING_EOL_CRLF, and 2
+ means CODING_EOL_CR. If it is not integer, it should be a vector
+ of subsidiary coding systems of which property `eol-type' has one
+ of above values.
+
+*/
+
+/* Extract information for decoding/encoding from CODING_SYSTEM_SYMBOL
+ and set it in CODING. If CODING_SYSTEM_SYMBOL is invalid, CODING
+ is setup so that no conversion is necessary and return -1, else
+ return 0. */
+
+int
+setup_coding_system (coding_system_symbol, coding)
+ Lisp_Object coding_system_symbol;
+ struct coding_system *coding;
+{
+ Lisp_Object coding_system_vector = Qnil;
+ Lisp_Object type, eol_type;
+
+ /* At first, set several fields default values. */
+ coding->require_flushing = 0;
+ coding->last_block = 0;
+ coding->selective = 0;
+ coding->composing = 0;
+ coding->direction = 0;
+ coding->carryover_size = 0;
+ coding->symbol = Qnil;
+ coding->post_read_conversion = coding->pre_write_conversion = Qnil;
+
+ /* Get value of property `coding-system'. If it is a Lisp symbol
+ pointing another coding system, fetch its property until we get a
+ vector. */
+ while (!NILP (coding_system_symbol))
+ {
+ coding->symbol = coding_system_symbol;
+ if (NILP (coding->post_read_conversion))
+ coding->post_read_conversion = Fget (coding_system_symbol,
+ Qpost_read_conversion);
+ if (NILP (coding->pre_write_conversion))
+ coding->pre_write_conversion = Fget (coding_system_symbol,
+ Qpre_write_conversion);
+
+ coding_system_vector = Fget (coding_system_symbol, Qcoding_system);
+ if (VECTORP (coding_system_vector))
+ break;
+ coding_system_symbol = coding_system_vector;
+ }
+ Vlast_coding_system_used = coding->symbol;
+
+ if (!VECTORP (coding_system_vector)
+ || XVECTOR (coding_system_vector)->size != 5)
+ goto label_invalid_coding_system;
+
+ /* Get value of property `eol-type' by searching from the root
+ coding-system. */
+ coding_system_symbol = coding->symbol;
+ eol_type = Qnil;
+ while (SYMBOLP (coding_system_symbol) && !NILP (coding_system_symbol))
+ {
+ eol_type = Fget (coding_system_symbol, Qeol_type);
+ if (!NILP (eol_type))
+ break;
+ coding_system_symbol = Fget (coding_system_symbol, Qcoding_system);
+ }
+
+ if (VECTORP (eol_type))
+ coding->eol_type = CODING_EOL_AUTOMATIC;
+ else if (XFASTINT (eol_type) == 1)
+ coding->eol_type = CODING_EOL_CRLF;
+ else if (XFASTINT (eol_type) == 2)
+ coding->eol_type = CODING_EOL_CR;
+ else
+ coding->eol_type = CODING_EOL_LF;
+
+ type = XVECTOR (coding_system_vector)->contents[0];
+ switch (XFASTINT (type))
+ {
+ case 0:
+ coding->type = coding_type_internal;
+ break;
+
+ case 1:
+ coding->type = coding_type_sjis;
+ break;
+
+ case 2:
+ coding->type = coding_type_iso2022;
+ {
+ Lisp_Object val = XVECTOR (coding_system_vector)->contents[4];
+ Lisp_Object *flags;
+ int i, charset, default_reg_bits = 0;
+
+ if (!VECTORP (val) || XVECTOR (val)->size != 32)
+ goto label_invalid_coding_system;
+
+ flags = XVECTOR (val)->contents;
+ coding->flags
+ = ((NILP (flags[4]) ? 0 : CODING_FLAG_ISO_SHORT_FORM)
+ | (NILP (flags[5]) ? 0 : CODING_FLAG_ISO_RESET_AT_EOL)
+ | (NILP (flags[6]) ? 0 : CODING_FLAG_ISO_RESET_AT_CNTL)
+ | (NILP (flags[7]) ? 0 : CODING_FLAG_ISO_SEVEN_BITS)
+ | (NILP (flags[8]) ? 0 : CODING_FLAG_ISO_LOCKING_SHIFT)
+ | (NILP (flags[9]) ? 0 : CODING_FLAG_ISO_SINGLE_SHIFT)
+ | (NILP (flags[10]) ? 0 : CODING_FLAG_ISO_USE_ROMAN)
+ | (NILP (flags[11]) ? 0 : CODING_FLAG_ISO_USE_OLDJIS)
+ | (NILP (flags[12]) ? 0 : CODING_FLAG_ISO_NO_DIRECTION));
+
+ /* Invoke graphic register 0 to plane 0. */
+ CODING_SPEC_ISO_INVOCATION (coding, 0) = 0;
+ /* Invoke graphic register 1 to plane 1 if we can use full 8-bit. */
+ CODING_SPEC_ISO_INVOCATION (coding, 1)
+ = (coding->flags & CODING_FLAG_ISO_SEVEN_BITS ? -1 : 1);
+ /* Not single shifting at first. */
+ CODING_SPEC_ISO_SINGLE_SHIFTING(coding) = 0;
+
+ /* Checks FLAGS[REG] (REG = 0, 1, 2 3) and decide designations.
+ FLAGS[REG] can be one of below:
+ integer CHARSET: CHARSET occupies register I,
+ t: designate nothing to REG initially, but can be used
+ by any charsets,
+ list of integer, nil, or t: designate the first
+ element (if integer) to REG initially, the remaining
+ elements (if integer) is designated to REG on request,
+ if an element is t, REG can be used by any charset,
+ nil: REG is never used. */
+ for (charset = 0; charset < MAX_CHARSET; charset++)
+ CODING_SPEC_ISO_REQUESTED_DESIGNATION (coding, charset) = -1;
+ for (i = 0; i < 4; i++)
+ {
+ if (INTEGERP (flags[i])
+ && (charset = XINT (flags[i]), CHARSET_VALID_P (charset)))
+ {
+ CODING_SPEC_ISO_INITIAL_DESIGNATION (coding, i) = charset;
+ CODING_SPEC_ISO_REQUESTED_DESIGNATION (coding, charset) = i;
+ }
+ else if (EQ (flags[i], Qt))
+ {
+ CODING_SPEC_ISO_INITIAL_DESIGNATION (coding, i) = -1;
+ default_reg_bits |= 1 << i;
+ }
+ else if (CONSP (flags[i]))
+ {
+ Lisp_Object tail = flags[i];
+
+ if (INTEGERP (XCONS (tail)->car)
+ && (charset = XINT (XCONS (tail)->car),
+ CHARSET_VALID_P (charset)))
+ {
+ CODING_SPEC_ISO_INITIAL_DESIGNATION (coding, i) = charset;
+ CODING_SPEC_ISO_REQUESTED_DESIGNATION (coding, charset) =i;
+ }
+ else
+ CODING_SPEC_ISO_INITIAL_DESIGNATION (coding, i) = -1;
+ tail = XCONS (tail)->cdr;
+ while (CONSP (tail))
+ {
+ if (INTEGERP (XCONS (tail)->car)
+ && (charset = XINT (XCONS (tail)->car),
+ CHARSET_VALID_P (charset)))
+ CODING_SPEC_ISO_REQUESTED_DESIGNATION (coding, charset)
+ = i;
+ else if (EQ (XCONS (tail)->car, Qt))
+ default_reg_bits |= 1 << i;
+ tail = XCONS (tail)->cdr;
+ }
+ }
+ else
+ CODING_SPEC_ISO_INITIAL_DESIGNATION (coding, i) = -1;
+
+ CODING_SPEC_ISO_DESIGNATION (coding, i)
+ = CODING_SPEC_ISO_INITIAL_DESIGNATION (coding, i);
+ }
+
+ if (! (coding->flags & CODING_FLAG_ISO_LOCKING_SHIFT))
+ {
+ /* REG 1 can be used only by locking shift in 7-bit env. */
+ if (coding->flags & CODING_FLAG_ISO_SEVEN_BITS)
+ default_reg_bits &= ~2;
+ if (! (coding->flags & CODING_FLAG_ISO_SINGLE_SHIFT))
+ /* Without any shifting, only REG 0 and 1 can be used. */
+ default_reg_bits &= 3;
+ }
+
+ for (charset = 0; charset < MAX_CHARSET; charset++)
+ if (CHARSET_VALID_P (charset)
+ && CODING_SPEC_ISO_REQUESTED_DESIGNATION (coding, charset) < 0)
+ {
+ /* We have not yet decided where to designate CHARSET. */
+ int reg_bits = default_reg_bits;
+
+ if (CHARSET_CHARS (charset) == 96)
+ /* A charset of CHARS96 can't be designated to REG 0. */
+ reg_bits &= ~1;
+
+ if (reg_bits)
+ /* There exist some default graphic register. */
+ CODING_SPEC_ISO_REQUESTED_DESIGNATION (coding, charset)
+ = (reg_bits & 1
+ ? 0 : (reg_bits & 2 ? 1 : (reg_bits & 4 ? 2 : 3)));
+ else
+ /* We anyway have to designate CHARSET to somewhere. */
+ CODING_SPEC_ISO_REQUESTED_DESIGNATION (coding, charset)
+ = (CHARSET_CHARS (charset) == 94
+ ? 0
+ : ((coding->flags & CODING_FLAG_ISO_LOCKING_SHIFT
+ || ! coding->flags & CODING_FLAG_ISO_SEVEN_BITS)
+ ? 1
+ : (coding->flags & CODING_FLAG_ISO_SINGLE_SHIFT
+ ? 2 : 0)));
+ }
+ }
+ coding->require_flushing = 1;
+ break;
+
+ case 3:
+ coding->type = coding_type_big5;
+ coding->flags
+ = (NILP (XVECTOR (coding_system_vector)->contents[4])
+ ? CODING_FLAG_BIG5_HKU
+ : CODING_FLAG_BIG5_ETEN);
+ break;
+
+ case 4:
+ coding->type = coding_type_ccl;
+ {
+ Lisp_Object val = XVECTOR (coding_system_vector)->contents[4];
+ if (CONSP (val)
+ && VECTORP (XCONS (val)->car)
+ && VECTORP (XCONS (val)->cdr))
+ {
+ setup_ccl_program (&(coding->spec.ccl.decoder), XCONS (val)->car);
+ setup_ccl_program (&(coding->spec.ccl.encoder), XCONS (val)->cdr);
+ }
+ else
+ goto label_invalid_coding_system;
+ }
+ coding->require_flushing = 1;
+ break;
+
+ default:
+ if (EQ (type, Qt))
+ coding->type = coding_type_automatic;
+ else
+ coding->type = coding_type_no_conversion;
+ break;
+ }
+ return 0;
+
+ label_invalid_coding_system:
+ coding->type = coding_type_no_conversion;
+ return -1;
+}
+
+/* Emacs has a mechanism to automatically detect a coding system if it
+ is one of Emacs' internal format, ISO2022, SJIS, and BIG5. But,
+ it's impossible to distinguish some coding systems accurately
+ because they use the same range of codes. So, at first, coding
+ systems are categorized into 7, those are:
+
+ o coding-category-internal
+
+ The category for a coding system which has the same code range
+ as Emacs' internal format. Assigned the coding-system (Lisp
+ symbol) `coding-system-internal' by default.
+
+ o coding-category-sjis
+
+ The category for a coding system which has the same code range
+ as SJIS. Assigned the coding-system (Lisp
+ symbol) `coding-system-sjis' by default.
+
+ o coding-category-iso-7
+
+ The category for a coding system which has the same code range
+ as ISO2022 of 7-bit environment. Assigned the coding-system
+ (Lisp symbol) `coding-system-junet' by default.
+
+ o coding-category-iso-8-1
+
+ The category for a coding system which has the same code range
+ as ISO2022 of 8-bit environment and graphic plane 1 used only
+ for DIMENSION1 charset. Assigned the coding-system (Lisp
+ symbol) `coding-system-ctext' by default.
+
+ o coding-category-iso-8-2
+
+ The category for a coding system which has the same code range
+ as ISO2022 of 8-bit environment and graphic plane 1 used only
+ for DIMENSION2 charset. Assigned the coding-system (Lisp
+ symbol) `coding-system-euc-japan' by default.
+
+ o coding-category-iso-else
+
+ The category for a coding system which has the same code range
+ as ISO2022 but not belongs to any of the above three
+ categories. Assigned the coding-system (Lisp symbol)
+ `coding-system-iso-2022-ss2-7' by default.
+
+ o coding-category-big5
+
+ The category for a coding system which has the same code range
+ as BIG5. Assigned the coding-system (Lisp symbol)
+ `coding-system-big5' by default.
+
+ o coding-category-binary
+
+ The category for a coding system not categorized in any of the
+ above. Assigned the coding-system (Lisp symbol)
+ `coding-system-noconv' by default.
+
+ Each of them is a Lisp symbol and the value is an actual
+ `coding-system's (this is also a Lisp symbol) assigned by a user.
+ What Emacs does actually is to detect a category of coding system.
+ Then, it uses a `coding-system' assigned to it. If Emacs can't
+ decide only one possible category, it selects a category of the
+ highest priority. Priorities of categories are also specified by a
+ user in a Lisp variable `coding-category-list'.
+
+*/
+
+/* Detect how a text of length SRC_BYTES pointed by SRC is encoded.
+ If it detects possible coding systems, return an integer in which
+ appropriate flag bits are set. Flag bits are defined by macros
+ CODING_CATEGORY_MASK_XXX in `coding.h'. */
+
+int
+detect_coding_mask (src, src_bytes)
+ unsigned char *src;
+ int src_bytes;
+{
+ register unsigned char c;
+ unsigned char *src_end = src + src_bytes;
+ int mask;
+
+ /* At first, skip all ASCII characters and control characters except
+ for three ISO2022 specific control characters. */
+ while (src < src_end)
+ {
+ c = *src;
+ if (c >= 0x80
+ || (c == ISO_CODE_ESC || c == ISO_CODE_SI || c == ISO_CODE_SO))
+ break;
+ src++;
+ }
+
+ if (src >= src_end)
+ /* We found nothing other than ASCII. There's nothing to do. */
+ return CODING_CATEGORY_MASK_ANY;
+
+ /* The text seems to be encoded in some multilingual coding system.
+ Now, try to find in which coding system the text is encoded. */
+ if (c < 0x80)
+ /* i.e. (c == ISO_CODE_ESC || c == ISO_CODE_SI || c == ISO_CODE_SO) */
+ /* C is an ISO2022 specific control code of C0. */
+ mask = detect_coding_iso2022 (src, src_end);
+
+ else if (c == ISO_CODE_SS2 || c == ISO_CODE_SS3 || c == ISO_CODE_CSI)
+ /* C is an ISO2022 specific control code of C1,
+ or the first byte of SJIS's 2-byte character code,
+ or a leading code of Emacs. */
+ mask = (detect_coding_iso2022 (src, src_end)
+ | detect_coding_sjis (src, src_end)
+ | detect_coding_internal (src, src_end));
+
+ else if (c < 0xA0)
+ /* C is the first byte of SJIS character code,
+ or a leading-code of Emacs. */
+ mask = (detect_coding_sjis (src, src_end)
+ | detect_coding_internal (src, src_end));
+
+ else
+ /* C is a character of ISO2022 in graphic plane right,
+ or a SJIS's 1-byte character code (i.e. JISX0201),
+ or the first byte of BIG5's 2-byte code. */
+ mask = (detect_coding_iso2022 (src, src_end)
+ | detect_coding_sjis (src, src_end)
+ | detect_coding_big5 (src, src_end));
+
+ return mask;
+}
+
+/* Detect how a text of length SRC_BYTES pointed by SRC is encoded.
+ The information of the detected coding system is set in CODING. */
+
+void
+detect_coding (coding, src, src_bytes)
+ struct coding_system *coding;
+ unsigned char *src;
+ int src_bytes;
+{
+ int mask = detect_coding_mask (src, src_bytes);
+ int idx;
+
+ if (mask == CODING_CATEGORY_MASK_ANY)
+ /* We found nothing other than ASCII. There's nothing to do. */
+ return;
+
+ if (!mask)
+ /* The source text seems to be encoded in unknown coding system.
+ Emacs regards the category of such a kind of coding system as
+ `coding-category-binary'. We assume that a user has assigned
+ an appropriate coding system for a `coding-category-binary'. */
+ idx = CODING_CATEGORY_IDX_BINARY;
+ else
+ {
+ /* We found some plausible coding systems. Let's use a coding
+ system of the highest priority. */
+ Lisp_Object val = Vcoding_category_list;
+
+ if (CONSP (val))
+ while (!NILP (val))
+ {
+ idx = XFASTINT (Fget (XCONS (val)->car, Qcoding_category_index));
+ if ((idx < CODING_CATEGORY_IDX_MAX) && (mask & (1 << idx)))
+ break;
+ val = XCONS (val)->cdr;
+ }
+ else
+ val = Qnil;
+
+ if (NILP (val))
+ {
+ /* For unknown reason, `Vcoding_category_list' contains none
+ of found categories. Let's use any of them. */
+ for (idx = 0; idx < CODING_CATEGORY_IDX_MAX; idx++)
+ if (mask & (1 << idx))
+ break;
+ }
+ }
+ setup_coding_system (XSYMBOL (coding_category_table[idx])->value, coding);
+}
+
+/* Detect how end-of-line of a text of length SRC_BYTES pointed by SRC
+ is encoded. Return one of CODING_EOL_LF, CODING_EOL_CRLF,
+ CODING_EOL_CR, and CODING_EOL_AUTOMATIC. */
+
+int
+detect_eol_type (src, src_bytes)
+ unsigned char *src;
+ int src_bytes;
+{
+ unsigned char *src_end = src + src_bytes;
+ unsigned char c;
+
+ while (src < src_end)
+ {
+ c = *src++;
+ if (c == '\n')
+ return CODING_EOL_LF;
+ else if (c == '\r')
+ {
+ if (src < src_end && *src == '\n')
+ return CODING_EOL_CRLF;
+ else
+ return CODING_EOL_CR;
+ }
+ }
+ return CODING_EOL_AUTOMATIC;
+}
+
+/* Detect how end-of-line of a text of length SRC_BYTES pointed by SRC
+ is encoded. If it detects an appropriate format of end-of-line, it
+ sets the information in *CODING. */
+
+void
+detect_eol (coding, src, src_bytes)
+ struct coding_system *coding;
+ unsigned char *src;
+ int src_bytes;
+{
+ Lisp_Object val;
+ int eol_type = detect_eol_type (src, src_bytes);
+
+ if (eol_type == CODING_EOL_AUTOMATIC)
+ /* We found no end-of-line in the source text. */
+ return;
+
+ val = Fget (coding->symbol, Qeol_type);
+ if (VECTORP (val) && XVECTOR (val)->size == 3)
+ setup_coding_system (XVECTOR (val)->contents[eol_type], coding);
+}
+
+/* See "GENERAL NOTES about `decode_coding_XXX ()' functions". Before
+ decoding, it may detect coding system and format of end-of-line if
+ those are not yet decided. */
+
+int
+decode_coding (coding, source, destination, src_bytes, dst_bytes, consumed)
+ struct coding_system *coding;
+ unsigned char *source, *destination;
+ int src_bytes, dst_bytes;
+ int *consumed;
+{
+ int produced;
+
+ if (src_bytes <= 0)
+ {
+ *consumed = 0;
+ return 0;
+ }
+
+ if (coding->type == coding_type_automatic)
+ detect_coding (coding, source, src_bytes);
+
+ if (coding->eol_type == CODING_EOL_AUTOMATIC)
+ detect_eol (coding, source, src_bytes);
+
+ coding->carryover_size = 0;
+ switch (coding->type)
+ {
+ case coding_type_no_conversion:
+ label_no_conversion:
+ produced = (src_bytes > dst_bytes) ? dst_bytes : src_bytes;
+ bcopy (source, destination, produced);
+ *consumed = produced;
+ break;
+
+ case coding_type_internal:
+ case coding_type_automatic:
+ if (coding->eol_type == CODING_EOL_LF
+ || coding->eol_type == CODING_EOL_AUTOMATIC)
+ goto label_no_conversion;
+ produced = decode_eol (coding, source, destination,
+ src_bytes, dst_bytes, consumed);
+ break;
+
+ case coding_type_sjis:
+ produced = decode_coding_sjis_big5 (coding, source, destination,
+ src_bytes, dst_bytes, consumed,
+ 1);
+ break;
+
+ case coding_type_iso2022:
+ produced = decode_coding_iso2022 (coding, source, destination,
+ src_bytes, dst_bytes, consumed);
+ break;
+
+ case coding_type_big5:
+ produced = decode_coding_sjis_big5 (coding, source, destination,
+ src_bytes, dst_bytes, consumed,
+ 0);
+ break;
+
+ case coding_type_ccl:
+ produced = ccl_driver (&coding->spec.ccl.decoder, source, destination,
+ src_bytes, dst_bytes, consumed);
+ break;
+ }
+
+ return produced;
+}
+
+/* See "GENERAL NOTES about `encode_coding_XXX ()' functions". */
+
+int
+encode_coding (coding, source, destination, src_bytes, dst_bytes, consumed)
+ struct coding_system *coding;
+ unsigned char *source, *destination;
+ int src_bytes, dst_bytes;
+ int *consumed;
+{
+ int produced;
+
+ coding->carryover_size = 0;
+ switch (coding->type)
+ {
+ case coding_type_no_conversion:
+ label_no_conversion:
+ produced = (src_bytes > dst_bytes) ? dst_bytes : src_bytes;
+ if (produced > 0)
+ {
+ bcopy (source, destination, produced);
+ if (coding->selective)
+ {
+ unsigned char *p = destination, *pend = destination + produced;
+ while (p < pend)
+ if (*p++ = '\015') p[-1] = '\n';
+ }
+ }
+ *consumed = produced;
+ break;
+
+ case coding_type_internal:
+ case coding_type_automatic:
+ if (coding->eol_type == CODING_EOL_LF
+ || coding->eol_type == CODING_EOL_AUTOMATIC)
+ goto label_no_conversion;
+ produced = encode_eol (coding, source, destination,
+ src_bytes, dst_bytes, consumed);
+ break;
+
+ case coding_type_sjis:
+ produced = encode_coding_sjis_big5 (coding, source, destination,
+ src_bytes, dst_bytes, consumed,
+ 1);
+ break;
+
+ case coding_type_iso2022:
+ produced = encode_coding_iso2022 (coding, source, destination,
+ src_bytes, dst_bytes, consumed);
+ break;
+
+ case coding_type_big5:
+ produced = encode_coding_sjis_big5 (coding, source, destination,
+ src_bytes, dst_bytes, consumed,
+ 0);
+ break;
+
+ case coding_type_ccl:
+ produced = ccl_driver (&coding->spec.ccl.encoder, source, destination,
+ src_bytes, dst_bytes, consumed);
+ break;
+ }
+
+ return produced;
+}
+
+#define CONVERSION_BUFFER_EXTRA_ROOM 256
+
+/* Return maximum size (bytes) of a buffer enough for decoding
+ SRC_BYTES of text encoded in CODING. */
+
+int
+decoding_buffer_size (coding, src_bytes)
+ struct coding_system *coding;
+ int src_bytes;
+{
+ int magnification;
+
+ if (coding->type == coding_type_iso2022)
+ magnification = 3;
+ else if (coding->type == coding_type_ccl)
+ magnification = coding->spec.ccl.decoder.buf_magnification;
+ else
+ magnification = 2;
+
+ return (src_bytes * magnification + CONVERSION_BUFFER_EXTRA_ROOM);
+}
+
+/* Return maximum size (bytes) of a buffer enough for encoding
+ SRC_BYTES of text to CODING. */
+
+int
+encoding_buffer_size (coding, src_bytes)
+ struct coding_system *coding;
+ int src_bytes;
+{
+ int magnification;
+
+ if (coding->type == coding_type_ccl)
+ magnification = coding->spec.ccl.encoder.buf_magnification;
+ else
+ magnification = 3;
+
+ return (src_bytes * magnification + CONVERSION_BUFFER_EXTRA_ROOM);
+}
+
+#ifndef MINIMUM_CONVERSION_BUFFER_SIZE
+#define MINIMUM_CONVERSION_BUFFER_SIZE 1024
+#endif
+
+char *conversion_buffer;
+int conversion_buffer_size;
+
+/* Return a pointer to a SIZE bytes of buffer to be used for encoding
+ or decoding. Sufficient memory is allocated automatically. If we
+ run out of memory, return NULL. */
+
+char *
+get_conversion_buffer (size)
+ int size;
+{
+ if (size > conversion_buffer_size)
+ {
+ char *buf;
+ int real_size = conversion_buffer_size * 2;
+
+ while (real_size < size) real_size *= 2;
+ buf = (char *) xmalloc (real_size);
+ xfree (conversion_buffer);
+ conversion_buffer = buf;
+ conversion_buffer_size = real_size;
+ }
+ return conversion_buffer;
+}
+
+\f
+#ifdef emacs
+/*** 7. Emacs Lisp library functions ***/
+
+DEFUN ("coding-system-vector", Fcoding_system_vector, Scoding_system_vector,
+ 1, 1, 0,
+ "Return coding-vector of CODING-SYSTEM.\n\
+If CODING-SYSTEM is not a valid coding-system, return nil.")
+ (obj)
+ Lisp_Object obj;
+{
+ while (SYMBOLP (obj) && !NILP (obj))
+ obj = Fget (obj, Qcoding_system);
+ return ((NILP (obj) || !VECTORP (obj) || XVECTOR (obj)->size != 5)
+ ? Qnil : obj);
+}
+
+DEFUN ("coding-system-p", Fcoding_system_p, Scoding_system_p, 1, 1, 0,
+ "Return t if OBJECT is nil or a coding-system.\n\
+See document of make-coding-system for coding-system object.")
+ (obj)
+ Lisp_Object obj;
+{
+ return ((NILP (obj) || !NILP (Fcoding_system_vector (obj))) ? Qt : Qnil);
+}
+
+DEFUN ("read-non-nil-coding-system",
+ Fread_non_nil_coding_system, Sread_non_nil_coding_system, 1, 1, 0,
+ "Read a coding-system from the minibuffer, prompting with string PROMPT.")
+ (prompt)
+ Lisp_Object prompt;
+{
+ return Fintern (Fcompleting_read (prompt, Vobarray, Qcoding_system_vector,
+ Qt, Qnil, Qnil),
+ Qnil);
+}
+
+DEFUN ("read-coding-system", Fread_coding_system, Sread_coding_system, 1, 1, 0,
+ "Read a coding-system or nil from the minibuffer, prompting with string PROMPT.")
+ (prompt)
+ Lisp_Object prompt;
+{
+ return Fintern (Fcompleting_read (prompt, Vobarray, Qcoding_system_p,
+ Qt, Qnil, Qnil),
+ Qnil);
+}
+
+DEFUN ("check-coding-system", Fcheck_coding_system, Scheck_coding_system,
+ 1, 1, 0,
+ "Check validity of CODING-SYSTEM.\n\
+If valid, return CODING-SYSTEM, else `coding-system-error' is signaled.\n\
+CODING-SYSTEM is valid if it is a symbol and has \"coding-system\" property.\n\
+The value of property should be a vector of length 5.")
+ (coding_system)
+ Lisp_Object coding_system;
+{
+ CHECK_SYMBOL (coding_system, 0);
+ if (!NILP (Fcoding_system_p (coding_system)))
+ return coding_system;
+ while (1)
+ Fsignal (Qcoding_system_error, coding_system);
+}
+
+DEFUN ("detect-coding-region", Fdetect_coding_region, Sdetect_coding_region,
+ 2, 2, 0,
+ "Detect coding-system of the text in the region between START and END.\n\
+Return a list of possible coding-systems ordered by priority.\n\
+If only ASCII characters are found, it returns `coding-system-automatic'\n\
+ or its subsidiary coding-system according to a detected end-of-line format.")
+ (b, e)
+ Lisp_Object b, e;
+{
+ int coding_mask, eol_type;
+ Lisp_Object val;
+ int beg, end;
+
+ validate_region (&b, &e);
+ beg = XINT (b), end = XINT (e);
+ if (beg < GPT && end >= GPT) move_gap (end);
+
+ coding_mask = detect_coding_mask (POS_ADDR (beg), end - beg);
+ eol_type = detect_eol_type (POS_ADDR (beg), end - beg);
+
+ if (coding_mask == CODING_CATEGORY_MASK_ANY)
+ {
+ val = intern ("coding-system-automatic");
+ if (eol_type != CODING_EOL_AUTOMATIC)
+ {
+ Lisp_Object val2 = Fget (val, Qeol_type);
+ if (VECTORP (val2))
+ val = XVECTOR (val2)->contents[eol_type];
+ }
+ }
+ else
+ {
+ Lisp_Object val2;
+
+ /* At first, gather possible coding-systems in VAL in a reverse
+ order. */
+ val = Qnil;
+ for (val2 = Vcoding_category_list;
+ !NILP (val2);
+ val2 = XCONS (val2)->cdr)
+ {
+ int idx
+ = XFASTINT (Fget (XCONS (val2)->car, Qcoding_category_index));
+ if (coding_mask & (1 << idx))
+ val = Fcons (Fsymbol_value (XCONS (val2)->car), val);
+ }
+
+ /* Then, change the order of the list, while getting subsidiary
+ coding-systems. */
+ val2 = val;
+ val = Qnil;
+ for (; !NILP (val2); val2 = XCONS (val2)->cdr)
+ {
+ if (eol_type == CODING_EOL_AUTOMATIC)
+ val = Fcons (XCONS (val2)->car, val);
+ else
+ {
+ Lisp_Object val3 = Fget (XCONS (val2)->car, Qeol_type);
+ if (VECTORP (val3))
+ val = Fcons (XVECTOR (val3)->contents[eol_type], val);
+ else
+ val = Fcons (XCONS (val2)->car, val);
+ }
+ }
+ }
+
+ return val;
+}
+
+/* Scan text in the region between *BEGP and *ENDP, skip characters
+ which we never have to encode to (iff ENCODEP is 1) or decode from
+ coding system CODING at the head and tail, then set BEGP and ENDP
+ to the addresses of start and end of the text we actually convert. */
+
+void
+shrink_conversion_area (begp, endp, coding, encodep)
+ unsigned char **begp, **endp;
+ struct coding_system *coding;
+ int encodep;
+{
+ register unsigned char *beg_addr = *begp, *end_addr = *endp;
+
+ if (coding->eol_type != CODING_EOL_LF
+ && coding->eol_type != CODING_EOL_AUTOMATIC)
+ /* Since we anyway have to convert end-of-line format, it is not
+ worth skipping at most 100 bytes or so. */
+ return;
+
+ if (encodep) /* for encoding */
+ {
+ switch (coding->type)
+ {
+ case coding_type_no_conversion:
+ case coding_type_internal:
+ case coding_type_automatic:
+ /* We need no conversion. */
+ *begp = *endp;
+ return;
+ case coding_type_ccl:
+ /* We can't skip any data. */
+ return;
+ default:
+ /* We can skip all ASCII characters at the head and tail. */
+ while (beg_addr < end_addr && *beg_addr < 0x80) beg_addr++;
+ while (beg_addr < end_addr && *(end_addr - 1) < 0x80) end_addr--;
+ break;
+ }
+ }
+ else /* for decoding */
+ {
+ switch (coding->type)
+ {
+ case coding_type_no_conversion:
+ /* We need no conversion. */
+ *begp = *endp;
+ return;
+ case coding_type_internal:
+ if (coding->eol_type == CODING_EOL_LF)
+ {
+ /* We need no conversion. */
+ *begp = *endp;
+ return;
+ }
+ /* We can skip all but carriage-return. */
+ while (beg_addr < end_addr && *beg_addr != '\r') beg_addr++;
+ while (beg_addr < end_addr && *(end_addr - 1) != '\r') end_addr--;
+ break;
+ case coding_type_sjis:
+ case coding_type_big5:
+ /* We can skip all ASCII characters at the head. */
+ while (beg_addr < end_addr && *beg_addr < 0x80) beg_addr++;
+ /* We can skip all ASCII characters at the tail except for
+ the second byte of SJIS or BIG5 code. */
+ while (beg_addr < end_addr && *(end_addr - 1) < 0x80) end_addr--;
+ if (end_addr != *endp)
+ end_addr++;
+ break;
+ case coding_type_ccl:
+ /* We can't skip any data. */
+ return;
+ default: /* i.e. case coding_type_iso2022: */
+ {
+ unsigned char c;
+
+ /* We can skip all ASCII characters except for a few
+ control codes at the head. */
+ while (beg_addr < end_addr && (c = *beg_addr) < 0x80
+ && c != ISO_CODE_CR && c != ISO_CODE_SO
+ && c != ISO_CODE_SI && c != ISO_CODE_ESC)
+ beg_addr++;
+ }
+ break;
+ }
+ }
+ *begp = beg_addr;
+ *endp = end_addr;
+ return;
+}
+
+/* Encode to (iff ENCODEP is 1) or decode form coding system CODING a
+ text between B and E. B and E are buffer position. */
+
+Lisp_Object
+code_convert_region (b, e, coding, encodep)
+ Lisp_Object b, e;
+ struct coding_system *coding;
+ int encodep;
+{
+ int beg, end, len, consumed, produced;
+ char *buf;
+ unsigned char *begp, *endp;
+ int pos = PT;
+
+ validate_region (&b, &e);
+ beg = XINT (b), end = XINT (e);
+ if (beg < GPT && end >= GPT)
+ move_gap (end);
+
+ if (encodep && !NILP (coding->pre_write_conversion))
+ {
+ /* We must call a pre-conversion function which may put a new
+ text to be converted in a new buffer. */
+ struct buffer *old = current_buffer, *new;
+
+ TEMP_SET_PT (beg);
+ call2 (coding->pre_write_conversion, b, e);
+ if (old != current_buffer)
+ {
+ /* Replace the original text by the text just generated. */
+ len = ZV - BEGV;
+ new = current_buffer;
+ set_buffer_internal (old);
+ del_range (beg, end);
+ insert_from_buffer (new, 1, len, 0);
+ end = beg + len;
+ }
+ }
+
+ /* We may be able to shrink the conversion region. */
+ begp = POS_ADDR (beg); endp = begp + (end - beg);
+ shrink_conversion_area (&begp, &endp, coding, encodep);
+
+ if (begp == endp)
+ /* We need no conversion. */
+ len = end - beg;
+ else
+ {
+ beg += begp - POS_ADDR (beg);
+ end = beg + (endp - begp);
+
+ if (encodep)
+ len = encoding_buffer_size (coding, end - beg);
+ else
+ len = decoding_buffer_size (coding, end - beg);
+ buf = get_conversion_buffer (len);
+
+ coding->last_block = 1;
+ produced = (encodep
+ ? encode_coding (coding, POS_ADDR (beg), buf, end - beg, len,
+ &consumed)
+ : decode_coding (coding, POS_ADDR (beg), buf, end - beg, len,
+ &consumed));
+
+ len = produced + (beg - XINT (b)) + (XINT (e) - end);
+
+ TEMP_SET_PT (beg);
+ insert (buf, produced);
+ del_range (PT, PT + end - beg);
+ if (pos >= end)
+ pos = PT + (pos - end);
+ else if (pos > beg)
+ pos = beg;
+ TEMP_SET_PT (pos);
+ }
+
+ if (!encodep && !NILP (coding->post_read_conversion))
+ {
+ /* We must call a post-conversion function which may alter
+ the text just converted. */
+ Lisp_Object insval;
+
+ beg = XINT (b);
+ TEMP_SET_PT (beg);
+ insval = call1 (coding->post_read_conversion, make_number (len));
+ CHECK_NUMBER (insval, 0);
+ len = XINT (insval);
+ }
+
+ return make_number (len);
+}
+
+Lisp_Object
+code_convert_string (str, coding, encodep)
+ Lisp_Object str;
+ struct coding_system *coding;
+ int encodep;
+{
+ int len, consumed, produced;
+ char *buf;
+ unsigned char *begp, *endp;
+ int head_skip, tail_skip;
+ struct gcpro gcpro1;
+
+ if (encodep && !NILP (coding->pre_write_conversion)
+ || !encodep && !NILP (coding->post_read_conversion))
+ {
+ /* Since we have to call Lisp functions which assume target text
+ is in a buffer, after setting a temporary buffer, call
+ code_convert_region. */
+ int count = specpdl_ptr - specpdl;
+ int len = XSTRING (str)->size;
+ Lisp_Object result;
+ struct buffer *old = current_buffer;
+
+ record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
+ temp_output_buffer_setup (" *code-converting-work*");
+ set_buffer_internal (XBUFFER (Vstandard_output));
+ insert_from_string (str, 0, len, 0);
+ code_convert_region (make_number (BEGV), make_number (ZV),
+ coding, encodep);
+ result = make_buffer_string (BEGV, ZV, 0);
+ set_buffer_internal (old);
+ return unbind_to (count, result);
+ }
+
+ /* We may be able to shrink the conversion region. */
+ begp = XSTRING (str)->data;
+ endp = begp + XSTRING (str)->size;
+ shrink_conversion_area (&begp, &endp, coding, encodep);
+
+ if (begp == endp)
+ /* We need no conversion. */
+ return str;
+
+ head_skip = begp - XSTRING (str)->data;
+ tail_skip = XSTRING (str)->size - head_skip - (endp - begp);
+
+ GCPRO1 (str);
+
+ if (encodep)
+ len = encoding_buffer_size (coding, endp - begp);
+ else
+ len = decoding_buffer_size (coding, endp - begp);
+ buf = get_conversion_buffer (len + head_skip + tail_skip);
+
+ bcopy (XSTRING (str)->data, buf, head_skip);
+ coding->last_block = 1;
+ produced = (encodep
+ ? encode_coding (coding, XSTRING (str)->data + head_skip,
+ buf + head_skip, endp - begp, len, &consumed)
+ : decode_coding (coding, XSTRING (str)->data + head_skip,
+ buf + head_skip, endp - begp, len, &consumed));
+ bcopy (XSTRING (str)->data + head_skip + (endp - begp),
+ buf + head_skip + produced,
+ tail_skip);
+
+ UNGCPRO;
+
+ return make_string (buf, head_skip + produced + tail_skip);
+}
+
+DEFUN ("decode-coding-region", Fdecode_coding_region, Sdecode_coding_region,
+ 3, 3, 0,
+ "Decode the text between START and END which is encoded in CODING-SYSTEM.\n\
+Return length of decoded text.")
+ (b, e, coding_system)
+ Lisp_Object b, e, coding_system;
+{
+ struct coding_system coding;
+
+ CHECK_NUMBER_COERCE_MARKER (b, 0);
+ CHECK_NUMBER_COERCE_MARKER (e, 1);
+ CHECK_SYMBOL (coding_system, 2);
+
+ if (setup_coding_system (Fcheck_coding_system (coding_system), &coding) < 0)
+ error ("Invalid coding-system: %s", XSYMBOL (coding_system)->name->data);
+
+ return code_convert_region (b, e, &coding, 0);
+}
+
+DEFUN ("encode-coding-region", Fencode_coding_region, Sencode_coding_region,
+ 3, 3, 0,
+ "Encode the text between START and END to CODING-SYSTEM.\n\
+Return length of encoded text.")
+ (b, e, coding_system)
+ Lisp_Object b, e, coding_system;
+{
+ struct coding_system coding;
+
+ CHECK_NUMBER_COERCE_MARKER (b, 0);
+ CHECK_NUMBER_COERCE_MARKER (e, 1);
+ CHECK_SYMBOL (coding_system, 2);
+
+ if (setup_coding_system (Fcheck_coding_system (coding_system), &coding) < 0)
+ error ("Invalid coding-system: %s", XSYMBOL (coding_system)->name->data);
+
+ return code_convert_region (b, e, &coding, 1);
+}
+
+DEFUN ("decode-coding-string", Fdecode_coding_string, Sdecode_coding_string,
+ 2, 2, 0,
+ "Decode STRING which is encoded in CODING-SYSTEM, and return the result.")
+ (string, coding_system)
+ Lisp_Object string, coding_system;
+{
+ struct coding_system coding;
+
+ CHECK_STRING (string, 0);
+ CHECK_SYMBOL (coding_system, 1);
+
+ if (setup_coding_system (Fcheck_coding_system (coding_system), &coding) < 0)
+ error ("Invalid coding-system: %s", XSYMBOL (coding_system)->name->data);
+
+ return code_convert_string (string, &coding, 0);
+}
+
+DEFUN ("encode-coding-string", Fencode_coding_string, Sencode_coding_string,
+ 2, 2, 0,
+ "Encode STRING to CODING-SYSTEM, and return the result.")
+ (string, coding_system)
+ Lisp_Object string, coding_system;
+{
+ struct coding_system coding;
+
+ CHECK_STRING (string, 0);
+ CHECK_SYMBOL (coding_system, 1);
+
+ if (setup_coding_system (Fcheck_coding_system (coding_system), &coding) < 0)
+ error ("Invalid coding-system: %s", XSYMBOL (coding_system)->name->data);
+
+ return code_convert_string (string, &coding, 1);
+}
+
+DEFUN ("decode-sjis-char", Fdecode_sjis_char, Sdecode_sjis_char, 1, 1, 0,
+ "Decode a JISX0208 character of SJIS coding-system-sjis.\n\
+CODE is the character code in SJIS.\n\
+Return the corresponding character.")
+ (code)
+ Lisp_Object code;
+{
+ unsigned char c1, c2, s1, s2;
+ Lisp_Object val;
+
+ CHECK_NUMBER (code, 0);
+ s1 = (XFASTINT (code)) >> 8, s2 = (XFASTINT (code)) & 0xFF;
+ DECODE_SJIS (s1, s2, c1, c2);
+ XSETFASTINT (val, MAKE_NON_ASCII_CHAR (charset_jisx0208, c1, c2));
+ return val;
+}
+
+DEFUN ("encode-sjis-char", Fencode_sjis_char, Sencode_sjis_char, 1, 1, 0,
+ "Encode a JISX0208 character CHAR to SJIS coding-system.\n\
+Return the corresponding character code in SJIS.")
+ (ch)
+ Lisp_Object ch;
+{
+ int charset;
+ unsigned char c1, c2, s1, s2;
+ Lisp_Object val;
+
+ CHECK_NUMBER (ch, 0);
+ SPLIT_CHAR (XFASTINT (ch), charset, c1, c2);
+ if (charset == charset_jisx0208)
+ {
+ ENCODE_SJIS (c1, c2, s1, s2);
+ XSETFASTINT (val, ((int)s1 << 8) | s2);
+ }
+ else
+ XSETFASTINT (val, 0);
+ return val;
+}
+
+DEFUN ("decode-big5-char", Fdecode_big5_char, Sdecode_big5_char, 1, 1, 0,
+ "Decode a Big5 character CODE of BIG5 coding-system.\n\
+CODE is the character code in BIG5.\n\
+Return the corresponding character.")
+ (code)
+ Lisp_Object code;
+{
+ int charset;
+ unsigned char b1, b2, c1, c2;
+ Lisp_Object val;
+
+ CHECK_NUMBER (code, 0);
+ b1 = (XFASTINT (code)) >> 8, b2 = (XFASTINT (code)) & 0xFF;
+ DECODE_BIG5 (b1, b2, charset, c1, c2);
+ XSETFASTINT (val, MAKE_NON_ASCII_CHAR (charset, c1, c2));
+ return val;
+}
+
+DEFUN ("encode-big5-char", Fencode_big5_char, Sencode_big5_char, 1, 1, 0,
+ "Encode the Big5 character CHAR to BIG5 coding-system.\n\
+Return the corresponding character code in Big5.")
+ (ch)
+ Lisp_Object ch;
+{
+ int charset;
+ unsigned char c1, c2, b1, b2;
+ Lisp_Object val;
+
+ CHECK_NUMBER (ch, 0);
+ SPLIT_CHAR (XFASTINT (ch), charset, c1, c2);
+ if (charset == charset_big5_1 || charset == charset_big5_2)
+ {
+ ENCODE_BIG5 (charset, c1, c2, b1, b2);
+ XSETFASTINT (val, ((int)b1 << 8) | b2);
+ }
+ else
+ XSETFASTINT (val, 0);
+ return val;
+}
+
+DEFUN ("set-terminal-coding-system",
+ Fset_terminal_coding_system, Sset_terminal_coding_system, 1, 1,
+ "zCoding-system for terminal display: ",
+ "Set coding-system of your terminal to CODING-SYSTEM.\n\
+All outputs to terminal are encoded to this coding-system.")
+ (coding_system)
+ Lisp_Object coding_system;
+{
+ CHECK_SYMBOL (coding_system, 0);
+ setup_coding_system (Fcheck_coding_system (coding_system), &terminal_coding);
+ update_mode_lines++;
+ if (!NILP (Finteractive_p ()))
+ Fredraw_display ();
+ return Qnil;
+}
+
+DEFUN ("terminal-coding-system",
+ Fterminal_coding_system, Sterminal_coding_system, 0, 0, 0,
+ "Return coding-system of your terminal.")
+ ()
+{
+ return terminal_coding.symbol;
+}
+
+DEFUN ("set-keyboard-coding-system",
+ Fset_keyboard_coding_system, Sset_keyboard_coding_system, 1, 1,
+ "zCoding-system for keyboard input: ",
+ "Set coding-system of what is sent from terminal keyboard to CODING-SYSTEM.\n\
+All inputs from terminal are decoded from this coding-system.")
+ (coding_system)
+ Lisp_Object coding_system;
+{
+ CHECK_SYMBOL (coding_system, 0);
+ setup_coding_system (Fcheck_coding_system (coding_system), &keyboard_coding);
+ return Qnil;
+}
+
+DEFUN ("keyboard-coding-system",
+ Fkeyboard_coding_system, Skeyboard_coding_system, 0, 0, 0,
+ "Return coding-system of what is sent from terminal keyboard.")
+ ()
+{
+ return keyboard_coding.symbol;
+}
+
+\f
+DEFUN ("find-coding-system", Ffind_coding_system, Sfind_coding_system,
+ 1, MANY, 0,
+ "Return a cons of coding systems for I/O primitive OPERATION.\n\
+Remaining arguments are for OPERATION.\n\
+OPERATION is one of the following Emacs I/O primitives:\n\
+ For file I/O, insert-file-contents or write-region.\n\
+ For process I/O, call-process, call-process-region, or start-process.\n\
+ For network I/O, open-network-stream.\n\
+For each OPERATION, TARGET is selected from the arguments as below:\n\
+ For file I/O, TARGET is a file name.\n\
+ For process I/O, TARGET is a process name.\n\
+ For network I/O, TARGET is a service name or a port number\n\
+\n\
+The return value is a cons of coding systems for decoding and encoding\n\
+registered in nested alist `coding-system-alist' (which see) at a slot\n\
+corresponding to OPERATION and TARGET.
+If a function symbol is at the slot, return a result of the function call.\n\
+The function is called with one argument, a list of all the arguments.")
+ (nargs, args)
+ int nargs;
+ Lisp_Object *args;
+{
+ Lisp_Object operation, target_idx, target, val;
+ register Lisp_Object chain;
+
+ if (nargs < 2)
+ error ("Too few arguments");
+ operation = args[0];
+ if (!SYMBOLP (operation)
+ || !INTEGERP (target_idx = Fget (operation, Qtarget_idx)))
+ error ("Invalid first arguement");
+ if (nargs < 1 + XINT (target_idx))
+ error ("Too few arguments for operation: %s",
+ XSYMBOL (operation)->name->data);
+ target = args[XINT (target_idx) + 1];
+ if (!(STRINGP (target)
+ || (EQ (operation, Qopen_network_stream) && INTEGERP (target))))
+ error ("Invalid %dth argument", XINT (target_idx) + 1);
+
+ chain = Fassq (operation, Vcoding_system_alist);
+ if (NILP (chain))
+ return Qnil;
+
+ for (chain = XCONS (chain)->cdr; CONSP (chain); chain = XCONS (chain)->cdr)
+ {
+ Lisp_Object elt = XCONS (chain)->car;
+
+ if (CONSP (elt)
+ && ((STRINGP (target)
+ && STRINGP (XCONS (elt)->car)
+ && fast_string_match (XCONS (elt)->car, target) >= 0)
+ || (INTEGERP (target) && EQ (target, XCONS (elt)->car))))
+ return (CONSP (val = XCONS (elt)->cdr)
+ ? val
+ : ((SYMBOLP (val) && Fboundp (val)
+ ? call2 (val, Flist (nargs, args))
+ : Qnil)));
+ }
+ return Qnil;
+}
+
+#endif /* emacs */
+
+\f
+/*** 8. Post-amble ***/
+
+init_coding_once ()
+{
+ int i;
+
+ /* Emacs internal format specific initialize routine. */
+ for (i = 0; i <= 0x20; i++)
+ emacs_code_class[i] = EMACS_control_code;
+ emacs_code_class[0x0A] = EMACS_linefeed_code;
+ emacs_code_class[0x0D] = EMACS_carriage_return_code;
+ for (i = 0x21 ; i < 0x7F; i++)
+ emacs_code_class[i] = EMACS_ascii_code;
+ emacs_code_class[0x7F] = EMACS_control_code;
+ emacs_code_class[0x80] = EMACS_leading_code_composition;
+ for (i = 0x81; i < 0xFF; i++)
+ emacs_code_class[i] = EMACS_invalid_code;
+ emacs_code_class[LEADING_CODE_PRIVATE_11] = EMACS_leading_code_3;
+ emacs_code_class[LEADING_CODE_PRIVATE_12] = EMACS_leading_code_3;
+ emacs_code_class[LEADING_CODE_PRIVATE_21] = EMACS_leading_code_4;
+ emacs_code_class[LEADING_CODE_PRIVATE_22] = EMACS_leading_code_4;
+
+ /* ISO2022 specific initialize routine. */
+ for (i = 0; i < 0x20; i++)
+ iso_code_class[i] = ISO_control_code;
+ for (i = 0x21; i < 0x7F; i++)
+ iso_code_class[i] = ISO_graphic_plane_0;
+ for (i = 0x80; i < 0xA0; i++)
+ iso_code_class[i] = ISO_control_code;
+ for (i = 0xA1; i < 0xFF; i++)
+ iso_code_class[i] = ISO_graphic_plane_1;
+ iso_code_class[0x20] = iso_code_class[0x7F] = ISO_0x20_or_0x7F;
+ iso_code_class[0xA0] = iso_code_class[0xFF] = ISO_0xA0_or_0xFF;
+ iso_code_class[ISO_CODE_CR] = ISO_carriage_return;
+ iso_code_class[ISO_CODE_SO] = ISO_shift_out;
+ iso_code_class[ISO_CODE_SI] = ISO_shift_in;
+ iso_code_class[ISO_CODE_SS2_7] = ISO_single_shift_2_7;
+ iso_code_class[ISO_CODE_ESC] = ISO_escape;
+ iso_code_class[ISO_CODE_SS2] = ISO_single_shift_2;
+ iso_code_class[ISO_CODE_SS3] = ISO_single_shift_3;
+ iso_code_class[ISO_CODE_CSI] = ISO_control_sequence_introducer;
+
+ Qcoding_system = intern ("coding-system");
+ staticpro (&Qcoding_system);
+
+ Qeol_type = intern ("eol-type");
+ staticpro (&Qeol_type);
+
+ Qbuffer_file_coding_system = intern ("buffer-file-coding-system");
+ staticpro (&Qbuffer_file_coding_system);
+
+ Qpost_read_conversion = intern ("post-read-conversion");
+ staticpro (&Qpost_read_conversion);
+
+ Qpre_write_conversion = intern ("pre-write-conversion");
+ staticpro (&Qpre_write_conversion);
+
+ Qcoding_system_vector = intern ("coding-system-vector");
+ staticpro (&Qcoding_system_vector);
+
+ Qcoding_system_p = intern ("coding-system-p");
+ staticpro (&Qcoding_system_p);
+
+ Qcoding_system_error = intern ("coding-system-error");
+ staticpro (&Qcoding_system_error);
+
+ Fput (Qcoding_system_error, Qerror_conditions,
+ Fcons (Qcoding_system_error, Fcons (Qerror, Qnil)));
+ Fput (Qcoding_system_error, Qerror_message,
+ build_string ("Coding-system error"));
+
+ Qcoding_category_index = intern ("coding-category-index");
+ staticpro (&Qcoding_category_index);
+
+ {
+ int i;
+ for (i = 0; i < CODING_CATEGORY_IDX_MAX; i++)
+ {
+ coding_category_table[i] = intern (coding_category_name[i]);
+ staticpro (&coding_category_table[i]);
+ Fput (coding_category_table[i], Qcoding_category_index,
+ make_number (i));
+ }
+ }
+
+ conversion_buffer_size = MINIMUM_CONVERSION_BUFFER_SIZE;
+ conversion_buffer = (char *) xmalloc (MINIMUM_CONVERSION_BUFFER_SIZE);
+
+ setup_coding_system (Qnil, &keyboard_coding);
+ setup_coding_system (Qnil, &terminal_coding);
+}
+
+#ifdef emacs
+
+syms_of_coding ()
+{
+ Qtarget_idx = intern ("target-idx");
+ staticpro (&Qtarget_idx);
+
+ Fput (Qinsert_file_contents, Qtarget_idx, make_number (0));
+ Fput (Qwrite_region, Qtarget_idx, make_number (2));
+
+ Qcall_process = intern ("call-process");
+ staticpro (&Qcall_process);
+ Fput (Qcall_process, Qtarget_idx, make_number (0));
+
+ Qcall_process_region = intern ("call-process-region");
+ staticpro (&Qcall_process_region);
+ Fput (Qcall_process_region, Qtarget_idx, make_number (2));
+
+ Qstart_process = intern ("start-process");
+ staticpro (&Qstart_process);
+ Fput (Qstart_process, Qtarget_idx, make_number (2));
+
+ Qopen_network_stream = intern ("open-network-stream");
+ staticpro (&Qopen_network_stream);
+ Fput (Qopen_network_stream, Qtarget_idx, make_number (3));
+
+ defsubr (&Scoding_system_vector);
+ defsubr (&Scoding_system_p);
+ defsubr (&Sread_coding_system);
+ defsubr (&Sread_non_nil_coding_system);
+ defsubr (&Scheck_coding_system);
+ defsubr (&Sdetect_coding_region);
+ defsubr (&Sdecode_coding_region);
+ defsubr (&Sencode_coding_region);
+ defsubr (&Sdecode_coding_string);
+ defsubr (&Sencode_coding_string);
+ defsubr (&Sdecode_sjis_char);
+ defsubr (&Sencode_sjis_char);
+ defsubr (&Sdecode_big5_char);
+ defsubr (&Sencode_big5_char);
+ defsubr (&Sset_terminal_coding_system);
+ defsubr (&Sterminal_coding_system);
+ defsubr (&Sset_keyboard_coding_system);
+ defsubr (&Skeyboard_coding_system);
+ defsubr (&Sfind_coding_system);
+
+ DEFVAR_LISP ("coding-category-list", &Vcoding_category_list,
+ "List of coding-categories (symbols) ordered by priority.");
+ {
+ int i;
+
+ Vcoding_category_list = Qnil;
+ for (i = CODING_CATEGORY_IDX_MAX - 1; i >= 0; i--)
+ Vcoding_category_list
+ = Fcons (coding_category_table[i], Vcoding_category_list);
+ }
+
+ DEFVAR_LISP ("coding-system-for-read", &Vcoding_system_for_read,
+ "A variable of internal use only.\n\
+If the value is a coding system, it is used for decoding on read operation.\n\
+If not, an appropriate element in `coding-system-alist' (which see) is used.");
+ Vcoding_system_for_read = Qnil;
+
+ DEFVAR_LISP ("coding-system-for-write", &Vcoding_system_for_write,
+ "A variable of internal use only.\n\
+If the value is a coding system, it is used for encoding on write operation.\n\
+If not, an appropriate element in `coding-system-alist' (which see) is used.");
+ Vcoding_system_for_write = Qnil;
+
+ DEFVAR_LISP ("last-coding-system-used", &Vlast_coding_system_used,
+ "Coding-system used in the latest file or process I/O.");
+ Vlast_coding_system_used = Qnil;
+
+ DEFVAR_LISP ("coding-system-alist", &Vcoding_system_alist,
+ "Nested alist to decide a coding system for a specific I/O operation.\n\
+The format is ((OPERATION . ((REGEXP . CODING-SYSTEMS) ...)) ...).\n\
+
+OPERATION is one of the following Emacs I/O primitives:\n\
+ For file I/O, insert-file-contents and write-region.\n\
+ For process I/O, call-process, call-process-region, and start-process.\n\
+ For network I/O, open-network-stream.\n\
+In addition, for process I/O, `process-argument' can be specified for\n\
+encoding arguments of the process.\n\
+\n\
+REGEXP is a regular expression matching a target of OPERATION, where\n\
+target is a file name for file I/O operations, a process name for\n\
+process I/O operations, or a service name for network I/O\n\
+operations. REGEXP might be a port number for network I/O operation.\n\
+\n\
+CODING-SYSTEMS is a cons of coding systems to encode and decode\n\
+character code on OPERATION, or a function symbol returning the cons.\n\
+See the documentation of `find-coding-system' for more detail.");
+ Vcoding_system_alist = Qnil;
+
+ DEFVAR_INT ("eol-mnemonic-unix", &eol_mnemonic_unix,
+ "Mnemonic character indicating UNIX-like end-of-line format (i.e. LF) .");
+ eol_mnemonic_unix = '.';
+
+ DEFVAR_INT ("eol-mnemonic-dos", &eol_mnemonic_dos,
+ "Mnemonic character indicating DOS-like end-of-line format (i.e. CRLF).");
+ eol_mnemonic_dos = ':';
+
+ DEFVAR_INT ("eol-mnemonic-mac", &eol_mnemonic_mac,
+ "Mnemonic character indicating MAC-like end-of-line format (i.e. CR).");
+ eol_mnemonic_mac = '\'';
+
+ DEFVAR_INT ("eol-mnemonic-undecided", &eol_mnemonic_undecided,
+ "Mnemonic character indicating end-of-line format is not yet decided.");
+ eol_mnemonic_undecided = '-';
+
+ DEFVAR_LISP ("alternate-charset-table", &Valternate_charset_table,
+ "Alist of charsets vs the alternate charsets.\n\
+While decoding, if a charset (car part of an element) is found,\n\
+decode it as the alternate charset (cdr part of the element).");
+ Valternate_charset_table = Qnil;
+
+ DEFVAR_LISP ("charset-revision-table", &Vcharset_revision_alist,
+ "Alist of charsets vs revision numbers.\n\
+While encoding, if a charset (car part of an element) is found,\n\
+designate it with the escape sequence identifing revision (cdr part of the element).");
+ Vcharset_revision_alist = Qnil;
+}
+
+#endif /* emacs */
--- /dev/null
+/* Header for coding system handler.
+ Ver.1.0
+
+ Copyright (C) 1995 Free Software Foundation, Inc.
+ Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#ifndef _CODING_H
+#define _CODING_H
+
+#ifndef _CCL_H
+#include "../src/ccl.h"
+#endif
+
+/*** EMACS' INTERNAL FORMAT section ***/
+
+/* All code (1-byte) of Emacs' internal format is classified into one
+ of the followings. See also `charset.h'. */
+enum emacs_code_class_type
+ {
+ EMACS_control_code, /* Control codes in the range
+ 0x00..0x1F and 0x7F except for the
+ following two codes. */
+ EMACS_linefeed_code, /* 0x0A (linefeed) to denote
+ end-of-line. */
+ EMACS_carriage_return_code, /* 0x0D (carriage-return) to be used
+ in selective display mode. */
+ EMACS_ascii_code, /* ASCII characters. */
+ EMACS_leading_code_composition, /* Leading code of a composite
+ character. */
+ EMACS_leading_code_2, /* Base leading code of official
+ TYPE9N character. */
+ EMACS_leading_code_3, /* Base leading code of private TYPE9N
+ or official TYPE9Nx9N character. */
+ EMACS_leading_code_4, /* Base leading code of private
+ TYPE9Nx9N character. */
+ EMACS_invalid_code /* Invalid code, i.e. a base leading
+ code not yet assigned to any
+ charset, or a code of the range
+ 0xA0..0xFF. */
+ };
+
+extern enum emacs_code_class_type emacs_code_class[256];
+
+/*** ISO2022 section ***/
+
+/* Macros to define code of control characters for ISO2022's functions. */
+ /* code */ /* function */
+#define ISO_CODE_LF 0x0A /* line-feed */
+#define ISO_CODE_CR 0x0D /* carriage-return */
+#define ISO_CODE_SO 0x0E /* shift-out */
+#define ISO_CODE_SI 0x0F /* shift-in */
+#define ISO_CODE_SS2_7 0x19 /* single-shift-2 for 7-bit code */
+#define ISO_CODE_ESC 0x1B /* escape */
+#define ISO_CODE_SS2 0x8E /* single-shift-2 */
+#define ISO_CODE_SS3 0x8F /* single-shift-3 */
+#define ISO_CODE_CSI 0x9B /* control-sequence-introduce */
+
+/* All code (1-byte) of ISO2022 is classified into one of the
+ followings. */
+enum iso_code_class_type
+ {
+ ISO_control_code, /* Control codes in the range
+ 0x00..0x1F, 0x7F, and 0x80..0x9F,
+ except for the following seven
+ codes. */
+ ISO_carriage_return, /* ISO_CODE_CR (0x0D) */
+ ISO_shift_out, /* ISO_CODE_SO (0x0E) */
+ ISO_shift_in, /* ISO_CODE_SI (0x0F) */
+ ISO_single_shift_2_7, /* ISO_CODE_SS2_7 (0x19) */
+ ISO_escape, /* ISO_CODE_SO (0x1B) */
+ ISO_single_shift_2, /* ISO_CODE_SS2 (0x8E) */
+ ISO_single_shift_3, /* ISO_CODE_SS3 (0x8F) */
+ ISO_control_sequence_introducer, /* ISO_CODE_CSI (0x9B) */
+ ISO_0x20_or_0x7F, /* Codes of the values 0x20 or 0x7F. */
+ ISO_graphic_plane_0, /* Graphic codes in the range 0x21..0x7E. */
+ ISO_0xA0_or_0xFF, /* Codes of the values 0xA0 or 0xFF. */
+ ISO_graphic_plane_1 /* Graphic codes in the range 0xA1..0xFE. */
+ };
+
+/** The macros CODING_FLAG_ISO_XXX defines a flag bit of the `flags'
+ element in the structure `coding_system'. This information is used
+ while encoding a text to ISO2022. **/
+
+/* If set, produce short-form designation sequence (e.g. ESC $ A)
+ instead of long-form sequence (e.g. ESC $ ( A). */
+#define CODING_FLAG_ISO_SHORT_FORM 0x0001
+
+/* If set, reset graphic planes and registers at end-of-line to the
+ initial state. */
+#define CODING_FLAG_ISO_RESET_AT_EOL 0x0002
+
+/* If set, reset graphic planes and registers before any control
+ characters to the initial state. */
+#define CODING_FLAG_ISO_RESET_AT_CNTL 0x0004
+
+/* If set, encode by 7-bit environment. */
+#define CODING_FLAG_ISO_SEVEN_BITS 0x0008
+
+/* If set, use locking-shift function. */
+#define CODING_FLAG_ISO_LOCKING_SHIFT 0x0010
+
+/* If set, use single-shift function. Overwrite
+ CODING_FLAG_ISO_LOCKING_SHIFT. */
+#define CODING_FLAG_ISO_SINGLE_SHIFT 0x0020
+
+/* If set, designate JISX0201-Roman instead of ASCII. */
+#define CODING_FLAG_ISO_USE_ROMAN 0x0040
+
+/* If set, designate JISX0208-1978 instead of JISX0208-1983. */
+#define CODING_FLAG_ISO_USE_OLDJIS 0x0080
+
+/* If set, do not produce ISO6429's direction specifying sequence. */
+#define CODING_FLAG_ISO_NO_DIRECTION 0x0100
+
+/* Structure of the field `spec.iso2022' in the structure `coding_system'. */
+struct iso2022_spec
+{
+ /* The current graphic register invoked to each graphic plane. */
+ int current_invocation[2];
+
+ /* The current charset designated to each graphic register. */
+ int current_designation[4];
+
+ /* A charset initially designated to each graphic register. */
+ int initial_designation[4];
+
+ /* A graphic register to which each charset should be designated. */
+ int requested_designation[MAX_CHARSET];
+
+ /* Set to 1 temporarily only when graphic register 2 or 3 is invoked
+ by single-shift while encoding. */
+ int single_shifting;
+};
+
+/* Macros to access each field in the structure `spec.iso2022'. */
+#define CODING_SPEC_ISO_INVOCATION(coding, plane) \
+ coding->spec.iso2022.current_invocation[plane]
+#define CODING_SPEC_ISO_DESIGNATION(coding, reg) \
+ coding->spec.iso2022.current_designation[reg]
+#define CODING_SPEC_ISO_INITIAL_DESIGNATION(coding, reg) \
+ coding->spec.iso2022.initial_designation[reg]
+#define CODING_SPEC_ISO_REQUESTED_DESIGNATION(coding, charset) \
+ coding->spec.iso2022.requested_designation[charset]
+
+/* Set to 1 temporarily only when encoding a character with
+ single-shift function. */
+#define CODING_SPEC_ISO_SINGLE_SHIFTING(coding) \
+ coding->spec.iso2022.single_shifting
+
+/* Return a charset which is currently designated to the graphic plane
+ PLANE in the coding-system CODING. */
+#define CODING_SPEC_ISO_PLANE_CHARSET(coding, plane) \
+ CODING_SPEC_ISO_DESIGNATION \
+ (coding, CODING_SPEC_ISO_INVOCATION (coding, plane))
+
+/*** BIG5 section ***/
+
+/* Macros to denote each type of BIG5 coding system. */
+#define CODING_FLAG_BIG5_HKU 0x00 /* BIG5-HKU is one of variants of
+ BIG5 developed by Hong Kong
+ University. */
+#define CODING_FLAG_BIG5_ETEN 0x01 /* BIG5_ETen is one of variants
+ of BIG5 developed by the
+ company ETen in Taiwan. */
+
+/*** GENERAL section ***/
+
+/* Types of coding system. */
+enum coding_type
+ {
+ coding_type_no_conversion, /* A coding system which requires no
+ conversion for reading and writing
+ including end-of-line format. */
+ coding_type_internal, /* A coding system used in Emacs'
+ buffer and string. Requires no
+ conversion for reading and writing
+ except for end-of-line format. */
+ coding_type_automatic, /* A coding system which requires
+ automatic detection of a real
+ coding system. */
+ coding_type_sjis, /* SJIS coding system for Japanese. */
+ coding_type_iso2022, /* Any coding system of ISO2022
+ variants. */
+ coding_type_big5, /* BIG5 coding system for Chinese. */
+ coding_type_ccl /* The coding system of which decoder
+ and encoder are written in CCL. */
+ };
+
+/* Formats of end-of-line. */
+#define CODING_EOL_LF 0 /* Line-feed only, same as Emacs'
+ internal format. */
+#define CODING_EOL_CRLF 1 /* Sequence of carriage-return and
+ line-feed. */
+#define CODING_EOL_CR 2 /* Carriage-return only. */
+#define CODING_EOL_AUTOMATIC 3 /* This value is used to denote the
+ eol-type is not yet decided. */
+
+/* Character composition status while encoding/decoding. */
+#define COMPOSING_NO 0 /* not composing */
+#define COMPOSING_WITH_RULE_HEAD 1 /* 1st char of with-rule composing follow */
+#define COMPOSING_NO_RULE_HEAD 2 /* 1st char of no-rule composing follow */
+#define COMPOSING_WITH_RULE_TAIL 3 /* Nth char of with-rule composing follow */
+#define COMPOSING_NO_RULE_TAIL 4 /* Nth char of no-rule composing follow */
+#define COMPOSING_WITH_RULE_RULE 5 /* composition rule follow */
+
+/* 1 iff composing. */
+#define COMPOSING_P(composing) (composing)
+/* 1 iff 1st char of composing element follows. */
+#define COMPOSING_HEAD_P(composing) \
+ ((composing) && (composing) <= COMPOSING_NO_RULE_HEAD)
+/* 1 iff composing with embeded composition rule. */
+#define COMPOSING_WITH_RULE_P(composing) ((composing) & 1)
+
+struct coding_system
+{
+ /* Type of the coding system. */
+ enum coding_type type;
+
+ /* If the coding system requires specific code to be attached at the
+ tail of converted text, this value should be set to `1'. */
+ int require_flushing;
+
+ /* Flag bits of the coding system. The meaning of each bit depends
+ on the type of the coding system. */
+ unsigned int flags;
+
+ /* Type of end-of-line format (LF, CRLF, or CR) of the coding system. */
+ int eol_type;
+
+ /* Non-zero means that the current source text is the last block of the
+ whole text to be converted. */
+ int last_block;
+
+ /* Non-zero means that characters are being composed currently while
+ decoding or encoding. See macros COMPOSING_XXXX above for the
+ meaing of each non-zero value. */
+ int composing;
+
+ /* 0 (left-to-right) or 1 (right-to-left): the direction of the text
+ being processed currently. */
+ int direction;
+
+ /* Non-zero means that the current source text is in a buffer which
+ enables selective display. */
+ int selective;
+
+ /* Detailed information specific to each type of coding system. */
+ union spec
+ {
+ struct iso2022_spec iso2022;
+ struct ccl_spec ccl; /* Defined in ccl.h. */
+ } spec;
+
+ /* Backward pointer to the Lisp symbol of the coding system. */
+ Lisp_Object symbol;
+
+ /* Lisp function (symbol) to be called after decoding to do
+ additional conversion. */
+ Lisp_Object post_read_conversion;
+
+ /* Lisp function (symbol) to be called before encoding to do
+ additional conversion. */
+ Lisp_Object pre_write_conversion;
+
+ /* Carryover yielded by decoding/encoding incomplete source. No
+ coding-system yields more than 7-byte of carryover. This does
+ not include a text which is not processed because of short of
+ output buffer. */
+ char carryover[8];
+
+ /* Actual data length in the above array. */
+ int carryover_size;
+};
+
+/* Return 1 if the coding-system CODING requires conversion of
+ representation of a visible character (text). */
+#define CODING_REQUIRE_TEXT_CONVERSION(coding) \
+ ((coding)->type != coding_type_no_conversion \
+ && (coding)->type != coding_type_internal)
+
+/* Return 1 if the coding-system CODING requires conversion of the
+ format of end-of-line. */
+#define CODING_REQUIRE_EOL_CONVERSION(coding) \
+ ((coding)->eol_type != CODING_EOL_AUTOMATIC \
+ && (coding)->eol_type != CODING_EOL_LF)
+
+/* Return 1 if the coding-system CODING requires some conversion. */
+#define CODING_REQUIRE_CONVERSION(coding) \
+ (CODING_REQUIRE_TEXT_CONVERSION (coding) \
+ || CODING_REQUIRE_EOL_CONVERSION (coding))
+
+/* Index for each coding category in `coding_category_table' */
+#define CODING_CATEGORY_IDX_INTERNAL 0
+#define CODING_CATEGORY_IDX_SJIS 1
+#define CODING_CATEGORY_IDX_ISO_7 2
+#define CODING_CATEGORY_IDX_ISO_8_1 3
+#define CODING_CATEGORY_IDX_ISO_8_2 4
+#define CODING_CATEGORY_IDX_ISO_ELSE 5
+#define CODING_CATEGORY_IDX_BIG5 6
+#define CODING_CATEGORY_IDX_BINARY 7
+#define CODING_CATEGORY_IDX_MAX 8
+
+/* Definitions of flag bits returned by the function
+ detect_coding_mask (). */
+#define CODING_CATEGORY_MASK_INTERNAL (1 << CODING_CATEGORY_IDX_INTERNAL)
+#define CODING_CATEGORY_MASK_SJIS (1 << CODING_CATEGORY_IDX_SJIS)
+#define CODING_CATEGORY_MASK_ISO_7 (1 << CODING_CATEGORY_IDX_ISO_7)
+#define CODING_CATEGORY_MASK_ISO_8_1 (1 << CODING_CATEGORY_IDX_ISO_8_1)
+#define CODING_CATEGORY_MASK_ISO_8_2 (1 << CODING_CATEGORY_IDX_ISO_8_2)
+#define CODING_CATEGORY_MASK_ISO_ELSE (1 << CODING_CATEGORY_IDX_ISO_ELSE)
+#define CODING_CATEGORY_MASK_BIG5 (1 << CODING_CATEGORY_IDX_BIG5)
+
+/* This value is returned if detect_coding_mask () find nothing other
+ than ASCII characters. */
+#define CODING_CATEGORY_MASK_ANY \
+ ( CODING_CATEGORY_MASK_INTERNAL \
+ | CODING_CATEGORY_MASK_SJIS \
+ | CODING_CATEGORY_MASK_ISO_7 \
+ | CODING_CATEGORY_MASK_ISO_8_1 \
+ | CODING_CATEGORY_MASK_ISO_8_2 \
+ | CODING_CATEGORY_MASK_ISO_ELSE \
+ | CODING_CATEGORY_MASK_BIG5)
+
+/* Macros to decode or encode a character of JISX0208 in SJIS. S1 and
+ S2 are the 1st and 2nd position-codes of JISX0208 in SJIS coding
+ system. C1 and C2 are the 1st and 2nd position codes of Emacs'
+ internal format. */
+
+#define DECODE_SJIS(s1, s2, c1, c2) \
+ do { \
+ if (s2 >= 0x9F) \
+ c1 = s1 * 2 - (s1 >= 0xE0 ? 0x160 : 0xE0), \
+ c2 = s2 - 0x7E; \
+ else \
+ c1 = s1 * 2 - ((s1 >= 0xE0) ? 0x161 : 0xE1), \
+ c2 = s2 - ((s2 >= 0x7F) ? 0x20 : 0x1F); \
+ } while (0)
+
+#define ENCODE_SJIS(c1, c2, s1, s2) \
+ do { \
+ if (c1 & 1) \
+ s1 = c1 / 2 + ((c1 < 0x5F) ? 0x71 : 0xB1), \
+ s2 = c2 + ((c2 >= 0x60) ? 0x20 : 0x1F); \
+ else \
+ s1 = c1 / 2 + ((c1 < 0x5F) ? 0x70 : 0xB0), \
+ s2 = c2 + 0x7E; \
+ } while (0)
+
+/* Extern declarations. */
+extern int decode_coding (), encode_coding ();
+extern int decoding_buffer_size (), encoding_buffer_size ();
+extern int conversion_buffer_size;
+extern char *conversion_buffer, *get_conversion_buffer ();
+extern Lisp_Object Fcheck_coding_system ();
+extern Lisp_Object Qcoding_system, Qeol_type, Qcoding_category_index;
+extern Lisp_Object Qbuffer_file_coding_system;
+extern Lisp_Object Vcoding_category_list;
+
+/* Mnemonic character to indicate each type of end-of-line. */
+extern int eol_mnemonic_unix, eol_mnemonic_dos, eol_mnemonic_mac;
+/* Mnemonic character to indicate type of end-of-line is not yet decided. */
+extern int eol_mnemonic_undecided;
+
+/* Table of coding-systems currently assigned to each coding-category. */
+extern Lisp_Object coding_category_table[CODING_CATEGORY_IDX_MAX];
+/* Table of names of symbol for each coding-category. */
+extern char *coding_category_name[CODING_CATEGORY_IDX_MAX];
+
+#ifdef emacs
+extern Lisp_Object Qfile_coding_system;
+extern Lisp_Object Qcall_process, Qcall_process_region, Qprocess_argument;
+extern Lisp_Object Qstart_process, Qopen_network_stream;
+
+/* Coding-system for reading files and receiving data from process. */
+extern Lisp_Object Vcoding_system_for_read;
+/* Coding-system for writing files and sending data to process. */
+extern Lisp_Object Vcoding_system_for_write;
+/* Coding-system actually used in the latest I/O. */
+extern Lisp_Object Vlast_coding_system_used;
+
+/* Coding-system to be used for encoding terminal output. This
+ structure contains information of a coding-system specified by the
+ function `set-terminal-coding-system'. */
+extern struct coding_system terminal_coding;
+
+/* Coding-system of what is sent from terminal keyboard. This
+ structure contains information of a coding-system specified by the
+ function `set-keyboard-coding-system'. */
+extern struct coding_system keyboard_coding;
+
+extern Lisp_Object Vcoding_system_alist;
+
+#endif
+
+#endif /* _CODING_H */
--- /dev/null
+/* Fontset handler.
+ Ver.1.0
+
+ Copyright (C) 1995 Free Software Foundation, Inc.
+ Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#include <config.h>
+#if HAVE_ALLOCA_H
+#include <alloca.h>
+#endif /* HAVE_ALLOCA_H */
+#include "lisp.h"
+#include "charset.h"
+#include "ccl.h"
+#include "fontset.h"
+#include "frame.h"
+
+Lisp_Object Vglobal_fontset_alist;
+
+Lisp_Object Vfont_encoding_alist;
+
+/* We had better have our own strcasecmp function because some system
+ doesn't have it. */
+static char my_strcasetbl[256];
+
+/* Compare two strings S0 and S1 while ignoring differences in case.
+ Return 1 if they differ, else return 0. */
+static int
+my_strcasecmp (s0, s1)
+ unsigned char *s0, *s1;
+{
+ while (*s0)
+ if (my_strcasetbl[*s0++] != my_strcasetbl[*s1++]) return 1;
+ return (int) *s1;
+}
+
+/* The following six are window system dependent functions. See
+ the comments in src/fontset.h for more detail. */
+
+/* Return a pointer to struct font_info of font FONT_IDX of frame F. */
+struct font_info *(*get_font_info_func) (/* FRAME_PTR f; int font_idx */);
+
+/* Return a list of font names which matches PATTERN. See the document of
+ `x-list-fonts' for more detail. */
+Lisp_Object (*list_fonts_func) (/* Lisp_Object pattern, face, frame, width */);
+
+/* Load a font named NAME for frame F and return a pointer to the
+ information of the loaded font. If loading is failed, return 0. */
+struct font_info *(*load_font_func) (/* FRAME_PTR f; char *name */);
+
+/* Return a pointer to struct font_info of a font named NAME for frame F. */
+struct font_info *(*query_font_func) (/* FRAME_PTR f; char *name */);
+
+/* Additional function for setting fontset or changing fontset
+ contents of frame F. */
+void (*set_frame_fontset_func) (/* FRAME_PTR f; Lisp_Object arg, oldval */);
+
+/* Check if any window system is used now. */
+void (*check_window_system_func) ();
+
+struct fontset_data *
+alloc_fontset_data ()
+{
+ struct fontset_data *fontset_data
+ = (struct fontset_data *) xmalloc (sizeof (struct fontset_data));
+
+ bzero (fontset_data, sizeof (struct fontset_data));
+
+ return fontset_data;
+}
+
+void
+free_fontset_data (fontset_data)
+ struct fontset_data *fontset_data;
+{
+ int i;
+
+ for (i = 0; i < fontset_data->n_fontsets; i++)
+ {
+ int j;
+
+ xfree (fontset_data->fontset_table[i]->name);
+ for (j = 0; j < MAX_CHARSET; j++)
+ if (fontset_data->fontset_table[i]->fontname[j])
+ xfree (fontset_data->fontset_table[i]->fontname[j]);
+ xfree (fontset_data->fontset_table[i]);
+ }
+ xfree (fontset_data->fontset_table);
+
+ xfree (fontset_data);
+}
+
+/* Load a font named FONTNAME for displaying CHARSET on frame F.
+ All fonts for frame F is stored in a table pointed by FONT_TABLE.
+ Return a pointer to the struct font_info of the loaded font.
+ If loading fails, return 0;
+ If FONTNAME is NULL, the name is taken from the information of FONTSET.
+ If FONTSET is given, try to load a font whose size matches that of
+ FONTSET, and, the font index is stored in the table for FONTSET. */
+
+struct font_info *
+fs_load_font (f, font_table, charset, fontname, fontset)
+ FRAME_PTR f;
+ struct font_info *font_table;
+ int charset, fontset;
+ char *fontname;
+{
+ Lisp_Object font_list;
+ Lisp_Object list, elt;
+ int font_idx;
+ int size = 0;
+ struct fontset_info *fontsetp = 0;
+ struct font_info *fontp;
+
+ if (fontset >= 0 && fontset < FRAME_FONTSET_DATA (f)->n_fontsets)
+ {
+ fontsetp = FRAME_FONTSET_DATA (f)->fontset_table[fontset];
+ font_idx = fontsetp->font_indexes[charset];
+ if (font_idx >= 0)
+ /* We have already loaded a font. */
+ return font_table + font_idx;
+ else if (font_idx == FONT_NOT_FOUND)
+ /* We have already tried loading a font and failed. */
+ return 0;
+ if (!fontname)
+ fontname = fontsetp->fontname[charset];
+ }
+
+ if (!fontname)
+ /* No way to get fontname. */
+ return 0;
+
+ /* If a fontset is specified and we have already loaded some fonts
+ in the fontset, we need a font of appropriate size to be used
+ with the fonts. */
+ if (fontsetp && fontsetp->size)
+ size = fontsetp->size * CHARSET_WIDTH (charset);
+
+ fontp = (*load_font_func) (f, fontname, size);
+
+ if (!fontp)
+ {
+ if (fontsetp)
+ fontsetp->font_indexes[charset] = FONT_NOT_FOUND;
+ return 0;
+ }
+
+ /* Fill in fields (CHARSET, ENCODING, and FONT_ENCODER) which are
+ not set by (*load_font_func). */
+ fontp->charset = charset;
+
+ if (fontp->encoding[1] >= 0)
+ {
+ /* The font itself tells which code points to be used. Use this
+ encoding for all other charsets. */
+ int i;
+
+ fontp->encoding[0] = fontp->encoding[1];
+ for (i = MIN_CHARSET_OFFICIAL_DIMENSION1; i < MAX_CHARSET; i++)
+ fontp->encoding[i] = fontp->encoding[1];
+ }
+ else
+ {
+ /* The font itself doesn't tell which code points to be used. */
+ int i;
+
+ /* At first, set 1 (means 0xA0..0xFF) as the default. */
+ fontp->encoding[0] = 1;
+ for (i = MIN_CHARSET_OFFICIAL_DIMENSION1; i < MAX_CHARSET; i++)
+ fontp->encoding[i] = 1;
+ /* Then override them by a specification in Vfont_encoding_alist. */
+ for (list = Vfont_encoding_alist; CONSP (list); list = XCONS (list)->cdr)
+ {
+ elt = XCONS (list)->car;
+ if (CONSP (elt)
+ && STRINGP (XCONS (elt)->car) && CONSP (XCONS (elt)->cdr)
+ && (fast_string_match_ignore_case (XCONS (elt)->car, fontname)
+ >= 0))
+ {
+ Lisp_Object tmp;
+
+ for (tmp = XCONS (elt)->cdr; CONSP (tmp); tmp = XCONS (tmp)->cdr)
+ if (CONSP (XCONS (tmp)->car)
+ && INTEGERP (XCONS (XCONS (tmp)->car)->car)
+ && ((i = get_charset_id (XCONS (XCONS (tmp)->car)->car))
+ >= 0)
+ && INTEGERP (XCONS (XCONS (tmp)->car)->cdr)
+ && XFASTINT (XCONS (XCONS (tmp)->car)->cdr) < 4)
+ fontp->encoding[i]
+ = XFASTINT (XCONS (XCONS (tmp)->car)->cdr);
+ }
+ }
+ }
+
+ fontp->font_encoder = (struct ccl_program *) 0;
+ for (list = Vfont_ccl_encoder_alist; CONSP (list); list = XCONS (list)->cdr)
+ {
+ elt = XCONS (list)->car;
+ if (CONSP (elt)
+ && STRINGP (XCONS (elt)->car) && VECTORP (XCONS (elt)->cdr)
+ && fast_string_match_ignore_case (XCONS (elt)->car, fontname) >= 0)
+ {
+ fontp->font_encoder
+ = (struct ccl_program *) xmalloc (sizeof (struct ccl_program));
+ setup_ccl_program (fontp->font_encoder, XCONS (elt)->cdr);
+ break;
+ }
+ }
+
+ if (fontsetp)
+ {
+ fontsetp->font_indexes[charset] = fontp->font_idx;
+ if (fontsetp->size == 0)
+ fontsetp->size = fontp->size / CHARSET_WIDTH (charset);
+
+ if (charset == CHARSET_ASCII
+ && fontsetp->size != fontp->size)
+ {
+ /* When loading ASCII font of the different size from the
+ size of FONTSET, we have to update the size of FONTSET.
+ Since changing the size of FONTSET may make some fonts
+ already loaded inappropriate to be used in FONTSET, we
+ must delete the record of such fonts. In that case, we
+ also have to calculate the height of FONTSET from the
+ remaining fonts. */
+ int i;
+
+ fontsetp->size = fontp->size;
+ fontsetp->height = fontp->height;
+ for (i = CHARSET_ASCII + 1; i < MAX_CHARSET; i++)
+ {
+ font_idx = fontsetp->font_indexes[i];
+ if (font_idx >= 0)
+ {
+ struct font_info *fontp2 = font_table + font_idx;
+
+ if (fontp2->size != fontp->size * CHARSET_WIDTH (i))
+ fontsetp->font_indexes[i] = FONT_NOT_OPENED;
+ else if (fontsetp->height < fontp->height)
+ fontsetp->height = fontp->height;
+ }
+ }
+ }
+ else if (fontsetp->height < fontp->height)
+ fontsetp->height = fontp->height;
+ }
+
+ return fontp;
+}
+
+/* Return ID of the fontset named NAME on frame F. */
+
+int
+fs_query_fontset (f, name)
+ FRAME_PTR f;
+ char *name;
+{
+ struct fontset_data *fontset_data = FRAME_FONTSET_DATA (f);
+ int i;
+
+ for (i = 0; i < fontset_data->n_fontsets; i++)
+ if (!my_strcasecmp(name, fontset_data->fontset_table[i]->name))
+ return i;
+ return -1;
+}
+
+/* Register a fontset specified by FONTSET_INFO for frame FRAME.
+ Return the fontset ID if successfully registered, else return -1.
+ FONTSET_INFO is a cons of name of the fontset and FONTLIST, where
+ FONTLIST is an alist of charsets vs fontnames. */
+
+int
+fs_register_fontset (f, fontset_info)
+ FRAME_PTR f;
+ Lisp_Object fontset_info;
+{
+ struct fontset_data *fontset_data = FRAME_FONTSET_DATA (f);
+ Lisp_Object name, fontlist;
+ int fontset;
+ struct fontset_info *fontsetp;
+ int i;
+
+ if (!CONSP (fontset_info)
+ || !STRINGP (XCONS (fontset_info)->car)
+ || !CONSP (XCONS (fontset_info)->cdr))
+ /* Invalid data in FONTSET_INFO. */
+ return -1;
+
+ name = XCONS (fontset_info)->car;
+ if ((fontset = fs_query_fontset (f, XSTRING (name)->data)) >= 0)
+ /* This fontset already exists on frame F. */
+ return fontset;
+
+ fontsetp = (struct fontset_info *) xmalloc (sizeof (struct fontset_info));
+
+ fontsetp->name = (char *) xmalloc (XSTRING (name)->size + 1);
+ bcopy(XSTRING (name)->data, fontsetp->name, XSTRING (name)->size + 1);
+
+ fontsetp->size = fontsetp->height = 0;
+
+ for (i = 0; i < MAX_CHARSET; i++)
+ {
+ fontsetp->fontname[i] = (char *) 0;
+ fontsetp->font_indexes[i] = FONT_NOT_OPENED;
+ }
+
+ for (fontlist = XCONS (fontset_info)->cdr; CONSP (fontlist);
+ fontlist = XCONS (fontlist)->cdr)
+ {
+ Lisp_Object tem = Fcar (fontlist);
+ int charset;
+
+ if (CONSP (tem)
+ && (charset = get_charset_id (XCONS (tem)->car)) >= 0
+ && STRINGP (XCONS (tem)->cdr))
+ {
+ fontsetp->fontname[charset]
+ = (char *) xmalloc (XSTRING (XCONS (tem)->cdr)->size + 1);
+ bcopy (XSTRING (XCONS (tem)->cdr)->data,
+ fontsetp->fontname[charset],
+ XSTRING (XCONS (tem)->cdr)->size + 1);
+ }
+ else
+ /* Broken or invalid data structure. */
+ return -1;
+ }
+
+ /* Do we need to create the table? */
+ if (fontset_data->fontset_table_size == 0)
+ {
+ fontset_data->fontset_table_size = 8;
+ fontset_data->fontset_table
+ = (struct fontset_info **) xmalloc (fontset_data->fontset_table_size
+ * sizeof (struct fontset_info *));
+ }
+ /* Do we need to grow the table? */
+ else if (fontset_data->n_fontsets >= fontset_data->fontset_table_size)
+ {
+ fontset_data->fontset_table_size += 8;
+ fontset_data->fontset_table
+ = (struct fontset_info **) xrealloc (fontset_data->fontset_table,
+ fontset_data->fontset_table_size
+ * sizeof (struct fontset_info *));
+ }
+ fontset = fontset_data->n_fontsets++;
+ fontset_data->fontset_table[fontset] = fontsetp;
+
+ return fontset;
+}
+
+/* Cache data used by fontset_pattern_regexp. The car part is a
+ pattern string containing at least one wild card, the cdr part is
+ the corresponding regular expression. */
+static Lisp_Object Vcached_fontset_data;
+
+#define CACHED_FONTSET_NAME (XSTRING (XCONS (Vcached_fontset_data)->car)->data)
+#define CACHED_FONTSET_REGEX (XCONS (Vcached_fontset_data)->cdr)
+
+/* If fontset name PATTERN contains any wild card, return regular
+ expression corresponding to PATTERN. */
+
+Lisp_Object
+fontset_pattern_regexp (pattern)
+ Lisp_Object pattern;
+{
+ int nickname = 0;
+
+ if (!index (XSTRING (pattern)->data, '*')
+ && !index (XSTRING (pattern)->data, '?'))
+ /* PATTERN does not contain any wild cards. */
+ {
+ if (XSTRING (pattern)->size > 8
+ && ! bcmp (XSTRING (pattern)->data, "fontset-", 8))
+ /* Just a nickname of a fontset is specified. */
+ nickname = 1;
+ else
+ return Qnil;
+ }
+
+ if (!CONSP (Vcached_fontset_data)
+ || strcmp (XSTRING (pattern)->data, CACHED_FONTSET_NAME))
+ {
+ /* We must at first update the cached data. */
+ char *regex = (char *) alloca (XSTRING (pattern)->size * 2 + 3);
+ char *p0, *p1 = regex;
+
+ if (nickname)
+ {
+ /* Just prepend ".*-" to PATTERN. */
+ *p1++= '.'; *p1++= '*', *p1++= '-';
+ bcopy (XSTRING (pattern)->data, p1, XSTRING (pattern)->size);
+ p1 += XSTRING (pattern)->size;
+ }
+ else
+ {
+ /* Convert "*" to ".*", "?" to ".". */
+ *p1++ = '^';
+ for (p0 = XSTRING (pattern)->data; *p0; p0++)
+ {
+ if (*p0 == '*')
+ {
+ *p1++ = '.';
+ *p1++ = '*';
+ }
+ else if (*p0 == '?')
+ *p1++ == '.';
+ else
+ *p1++ = *p0;
+ }
+ }
+ *p1++ = '$';
+ *p1++ = 0;
+
+ Vcached_fontset_data = Fcons (build_string (XSTRING (pattern)->data),
+ build_string (regex));
+ }
+
+ return CACHED_FONTSET_REGEX;
+}
+
+DEFUN ("query-fontset", Fquery_fontset, Squery_fontset, 1, 1, 0,
+ "Return a fontset name which matches PATTERN, nil if no matching fontset.\n\
+PATTERN can contain `*' or `?' as a wild card\n\
+just like X's font name matching algorithm allows.")
+ (pattern)
+ Lisp_Object pattern;
+{
+ Lisp_Object regexp, tem;
+
+ (*check_window_system_func) ();
+
+ CHECK_STRING (pattern, 0);
+
+ if (XSTRING (pattern)->size == 0)
+ return Qnil;
+
+ regexp = fontset_pattern_regexp (pattern);
+
+ for (tem = Vglobal_fontset_alist; CONSP (tem); tem = XCONS (tem)->cdr)
+ {
+ Lisp_Object fontset_name = XCONS (XCONS (tem)->car)->car;
+ if (!NILP (regexp))
+ {
+ if (fast_string_match_ignore_case (regexp,
+ XSTRING (fontset_name)->data)
+ >= 0)
+ return fontset_name;
+ }
+ else
+ {
+ if (!my_strcasecmp (XSTRING (pattern)->data,
+ XSTRING (fontset_name)->data))
+ return fontset_name;
+ }
+ }
+
+ return Qnil;
+}
+
+Lisp_Object Fframe_char_width ();
+
+/* Return a list of names of available fontsets matching PATTERN on
+ frame F. If SIZE is not 0, it is the size (maximum bound width) of
+ fontsets to be listed. */
+
+Lisp_Object
+list_fontsets (f, pattern, size)
+ FRAME_PTR f;
+ Lisp_Object pattern;
+ int size;
+{
+ int i;
+ Lisp_Object regexp, val;
+
+ regexp = fontset_pattern_regexp (pattern);
+
+ val = Qnil;
+ for (i = 0; i < FRAME_FONTSET_DATA (f)->n_fontsets; i++)
+ {
+ struct fontset_info *fontsetp = FRAME_FONTSET_DATA (f)->fontset_table[i];
+ int name_matched = 0;
+ int size_matched = 0;
+
+ if (!NILP (regexp))
+ {
+ if (fast_string_match_ignore_case (regexp, fontsetp->name) >= 0)
+ name_matched = 1;
+ }
+ else
+ {
+ if (!my_strcasecmp (XSTRING (pattern)->data, fontsetp->name))
+ name_matched = 1;
+ }
+
+ if (name_matched)
+ {
+ if (!size || fontsetp->size == size)
+ size_matched = 1;
+ else if (fontsetp->size == 0)
+ {
+ /* No font of this fontset has loaded yet. Try loading
+ one with SIZE. */
+ int j;
+
+ for (j = 0; j < MAX_CHARSET; j++)
+ if (fontsetp->fontname[j])
+ {
+ if ((*load_font_func) (f, fontsetp->fontname[j], size))
+ size_matched = 1;
+ break;
+ }
+ }
+
+ if (size_matched)
+ val = Fcons (build_string (fontsetp->name), val);
+ }
+ }
+
+ return val;
+}
+
+DEFUN ("new-fontset", Fnew_fontset, Snew_fontset, 2, 2, 0,
+ "Create a new fontset NAME which contains fonts in FONTLIST.\n\
+FONTLIST is an alist of charsets vs corresponding font names.")
+ (name, fontlist)
+ Lisp_Object name, fontlist;
+{
+ Lisp_Object fullname, fontset_info;
+ Lisp_Object tail;
+
+ (*check_window_system_func) ();
+
+ CHECK_STRING (name, 0);
+ CHECK_LIST (fontlist, 1);
+
+ fullname = Fquery_fontset (name);
+ if (!NILP (fullname))
+ error ("Fontset \"%s\" matches the existing fontset \"%s\"",
+ XSTRING (name)->data, XSTRING (fullname)->data);
+
+ /* Check the validity of FONTLIST. */
+ for (tail = fontlist; CONSP (tail); tail = XCONS (tail)->cdr)
+ {
+ Lisp_Object tem = XCONS (tail)->car;
+ int charset;
+
+ if (!CONSP (tem)
+ || (charset = get_charset_id (XCONS (tem)->car)) < 0
+ || !STRINGP (XCONS (tem)->cdr))
+ error ("Elements of fontlist must be a cons of charset and font name");
+ }
+
+ fontset_info = Fcons (name, fontlist);
+ Vglobal_fontset_alist = Fcons (fontset_info, Vglobal_fontset_alist);
+
+ /* Register this fontset for all existing frames. */
+ {
+ Lisp_Object framelist, frame;
+
+ FOR_EACH_FRAME (framelist, frame)
+ if (!FRAME_TERMCAP_P (XFRAME (frame)))
+ fs_register_fontset (XFRAME (frame), fontset_info);
+ }
+
+ return Qnil;
+}
+
+extern Lisp_Object Fframe_parameters ();
+extern Lisp_Object Qfont;
+Lisp_Object Qfontset;
+
+DEFUN ("set-fontset-font", Fset_fontset_font, Sset_fontset_font, 3, 4, 0,
+ "Set FONTNAME for a font of CHARSET in fontset NAME on frame FRAME.\n\
+If FRAME is omitted or nil, all frames are affected.")
+ (name, charset_symbol, fontname, frame)
+ Lisp_Object name, charset_symbol, fontname, frame;
+{
+ int charset;
+ Lisp_Object fullname, fontlist;
+
+ (*check_window_system_func) ();
+
+ CHECK_STRING (name, 0);
+ CHECK_SYMBOL (charset_symbol, 1);
+ CHECK_STRING (fontname, 2);
+ if (!NILP (frame))
+ CHECK_LIVE_FRAME (frame, 3);
+
+ if ((charset = get_charset_id (charset_symbol)) < 0)
+ error ("Invalid charset: %s", XSYMBOL (charset_symbol)->name->data);
+
+ fullname = Fquery_fontset (name);
+ if (NILP (fullname))
+ error ("Fontset \"%s\" does not exist", XSTRING (name)->data);
+
+ /* If FRAME is not specified, we must, at first, update contents of
+ `global-fontset-alist' for a frame created in the future. */
+ if (NILP (frame))
+ {
+ Lisp_Object fontset_info = Fassoc (fullname, Vglobal_fontset_alist);
+ Lisp_Object tem = Fassq (charset, XCONS (fontset_info)->cdr);
+
+ if (NILP (tem))
+ XCONS (fontset_info)->cdr
+ = Fcons (Fcons (charset, fontname), XCONS (fontset_info)->cdr);
+ else
+ XCONS (tem)->cdr = fontname;
+ }
+
+ /* Then, update information in the specified frame or all existing
+ frames. */
+ {
+ Lisp_Object framelist, tem;
+
+ FOR_EACH_FRAME (framelist, tem)
+ if (!FRAME_TERMCAP_P (XFRAME (tem))
+ && (NILP (frame) || EQ (frame, tem)))
+ {
+ FRAME_PTR f = XFRAME (tem);
+ int fontset = fs_query_fontset (f, XSTRING (fullname)->data);
+ struct fontset_info *fontsetp
+ = FRAME_FONTSET_DATA (f)->fontset_table[fontset];
+
+ if (fontsetp->fontname[XINT (charset)])
+ xfree (fontsetp->fontname[XINT (charset)]);
+ fontsetp->fontname[XINT (charset)]
+ = (char *) xmalloc (XSTRING (fontname)->size + 1);
+ bcopy (XSTRING (fontname)->data, fontsetp->fontname[XINT (charset)],
+ XSTRING (fontname)->size + 1);
+ fontsetp->font_indexes[XINT (charset)] = FONT_NOT_OPENED;
+
+ if (charset == CHARSET_ASCII)
+ {
+ Lisp_Object font_param = Fassq (Qfont, Fframe_parameters (tem));
+
+ if (set_frame_fontset_func
+ && !NILP (font_param)
+ && !strcmp (XSTRING (fullname)->data,
+ XSTRING (XCONS (font_param)->cdr)->data))
+ /* This fontset is the default fontset on frame TEM.
+ We may have to resize this frame because of new
+ ASCII font. */
+ (*set_frame_fontset_func) (f, fullname, Qnil);
+ }
+ }
+ }
+
+ return Qnil;
+}
+
+DEFUN ("font-info", Ffont_info, Sfont_info, 1, 2, 0,
+ "Return information about a font named NAME on frame FRAME.\n\
+If FRAME is omitted or nil, use the selected frame.\n\
+The returned value is a vector of OPENED-NAME, FULL-NAME, CHARSET, SIZE,\n\
+ HEIGHT, BASELINE-OFFSET, and RELATIVE-COMPOSE,\n\
+where\n\
+ OPENED-NAME is the name used for opening the font,\n\
+ FULL-NAME is the full name of the font,\n\
+ CHARSET is the charset displayed by the font,\n\
+ SIZE is the minimum bound width of the font,\n\
+ HEIGHT is the height of the font,\n\
+ BASELINE-OFFSET is the upward offset pixels from ASCII baseline,\n\
+ RELATIVE-COMPOSE is the number controlling how to compose characters.\n\
+If the named font is not yet loaded, return nil.")
+ (name, frame)
+ Lisp_Object name, frame;
+{
+ FRAME_PTR f;
+ struct font_info *fontp;
+ Lisp_Object info;
+
+ (*check_window_system_func) ();
+
+ CHECK_STRING (name, 0);
+ if (NILP (frame))
+ f = selected_frame;
+ else
+ {
+ CHECK_LIVE_FRAME (frame, 1);
+ f = XFRAME (frame);
+ }
+
+ if (!query_font_func)
+ error ("Font query function is not supported");
+
+ fontp = (*query_font_func) (f, XSTRING (name)->data);
+ if (!fontp)
+ return Qnil;
+
+ info = Fmake_vector (make_number (6), Qnil);
+
+ XVECTOR (info)->contents[0] = build_string (fontp->name);
+ XVECTOR (info)->contents[1] = build_string (fontp->full_name);
+ XVECTOR (info)->contents[2] = CHARSET_SYMBOL (fontp->charset);
+ XVECTOR (info)->contents[3] = make_number (fontp->size);
+ XVECTOR (info)->contents[4] = make_number (fontp->height);
+ XVECTOR (info)->contents[5] = make_number (fontp->baseline_offset);
+ XVECTOR (info)->contents[6] = make_number (fontp->relative_compose);
+
+ return info;
+}
+
+DEFUN ("fontset-info", Ffontset_info, Sfontset_info, 1, 2, 0,
+ "Return information about a fontset named NAME on frame FRAME.\n\
+If FRAME is omitted or nil, use the selected frame.\n\
+The returned value is a vector of SIZE, HEIGHT, and FONT-LIST,\n\
+where\n\
+ SIZE is the minimum bound width of ASCII font of the fontset,\n\
+ HEIGHT is the height of the tallest font in the fontset, and\n\
+ FONT-LIST is an alist of the format:\n\
+ (CHARSET REQUESTED-FONT-NAME LOADED-FONT-NAME).\n\
+LOADED-FONT-NAME t means the font is not yet loaded, nil means the\n\
+loading failed.")
+ (name, frame)
+ Lisp_Object name, frame;
+{
+ FRAME_PTR f;
+ int fontset;
+ struct fontset_info *fontsetp;
+ Lisp_Object info, val;
+ int i;
+
+ (*check_window_system_func) ();
+
+ CHECK_STRING(name, 0);
+ if (NILP (frame))
+ f = selected_frame;
+ else
+ {
+ CHECK_LIVE_FRAME (frame, 1);
+ f = XFRAME (frame);
+ }
+
+ fontset = fs_query_fontset (f, XSTRING (name)->data);
+ if (fontset < 0)
+ error ("Fontset \"%s\" does not exist", XSTRING (name)->data);
+
+ info = Fmake_vector (make_number (3), Qnil);
+
+ fontsetp = FRAME_FONTSET_DATA (f)->fontset_table[fontset];
+
+ XVECTOR (info)->contents[0] = make_number (fontsetp->size);
+ XVECTOR (info)->contents[1] = make_number (fontsetp->height);
+ val = Qnil;
+ for (i = 0; i < MAX_CHARSET; i++)
+ if (fontsetp->fontname[i])
+ {
+ int font_idx = fontsetp->font_indexes[i];
+ Lisp_Object loaded;
+
+ if (font_idx == FONT_NOT_OPENED)
+ loaded = Qt;
+ else if (font_idx == FONT_NOT_FOUND)
+ loaded = Qnil;
+ else
+ loaded
+ = build_string ((*get_font_info_func) (f, font_idx)->full_name);
+ val = Fcons (Fcons (CHARSET_SYMBOL (i),
+ Fcons (build_string (fontsetp->fontname[i]),
+ Fcons (loaded, Qnil))),
+ val);
+ }
+ XVECTOR (info)->contents[2] = val;
+ return info;
+}
+
+syms_of_fontset ()
+{
+ int i;
+
+ for (i = 0; i < 256; i++)
+ my_strcasetbl[i] = (i >= 'A' && i <= 'Z') ? i + 'a' - 'A' : i;
+
+ if (!load_font_func)
+ /* Window system initializer should have set proper functions. */
+ abort ();
+
+ staticpro (&Qfontset);
+
+ Vcached_fontset_data = Qnil;
+ staticpro (&Vcached_fontset_data);
+
+ DEFVAR_LISP ("global-fontset-alist", &Vglobal_fontset_alist,
+ "Internal data for fontset. Not for external use.\n\
+This is an alist associating fontset names with the lists of fonts\n\
+ contained in them.\n\
+Newly created frames make their own fontset database from here.");
+ Vglobal_fontset_alist = Qnil;
+
+ DEFVAR_LISP ("font-encoding-alist", &Vfont_encoding_alist,
+ "Alist of fontname patterns vs corresponding encoding info.\n\
+Each element looks like (REGEXP . ENCODING-INFO),\n\
+ where ENCODING-INFO is an alist of CHARSET vs ENCODING.\n\
+ENCODING is one of the following integer values:\n\
+ 0: code points 0x20..0x7F or 0x2020..0x7F7F are used,\n\
+ 1: code points 0xA0..0xFF or 0xA0A0..0xFFFF are used,\n\
+ 2: code points 0x20A0..0x7FFF are used,\n\
+ 3: code points 0xA020..0xFF7F are used.");
+ Vfont_encoding_alist = Qnil;
+
+ defsubr (&Squery_fontset);
+ defsubr (&Snew_fontset);
+ defsubr (&Sset_fontset_font);
+ defsubr (&Sfont_info);
+ defsubr (&Sfontset_info);
+}
--- /dev/null
+/* Header for fontset handler.
+ Ver.1.0
+
+ Copyright (C) 1995 Free Software Foundation, Inc.
+ Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#ifndef _FONTSET_H
+#define _FONTSET_H
+
+/*
+
+#define GENERIC_FONT_PTR void
+
+/* This data type is used for the font_table field of window system
+ depending data area (e.g. struct x_display_info on X window). */
+
+struct font_info
+{
+ /* Pointer to window system dependent font structure. On X window,
+ this value should be coerced to (XFontStruct *). */
+ void *font;
+
+ /* Index number of the font. */
+ int font_idx;
+
+ /* Name to be used to find the font. */
+ char *name;
+
+ /* Full name of the font given by a window system. */
+ char *full_name;
+
+ /* Charset of characters displayed by the font. */
+ int charset;
+
+ /* Maximum bound width over all existing characters of the font. On
+ X window, this is same as (font->max_bounds.width) */
+ int size;
+
+ /* Height of the font. On X window, this is same as (font->ascent
+ + font->descent). */
+ int height;
+
+ /* Encodings of the font indexed by CHARSET. The value an integer
+ 0, 1, 2, or 3:
+ 0: code points 0x20..0x7F or 0x2020..0x7F7F are used
+ 1: code points 0xA0..0xFF or 0xA0A0..0xFFFF are used
+ 2: code points 0x20A0..0x7FFF are used
+ 3: code points 0xA020..0xFF7F are used
+ For instance, ASCII and Latin-1 characters may use the same font
+ but different code points (ASCII uses 0x20..0x7F and Latin-1 uses
+ 0xA0..0xFF).
+
+ If the value can't be decided from information of the font, we
+ consult `font-encoding-alist' to get of the corresponding charset
+ whose default value is defined in lisp/fontset.el. Since there's
+ no charset whose id is 1, we use encoding[1] to store the
+ encoding information decided by the font itself. */
+ char encoding[MAX_CHARSET];
+
+ /* The baseline position of a font is normally `ascent' value of the
+ font. However, there exists many fonts which don't set `ascent'
+ an appropriate value to be used as baseline position. This is
+ typical in such ASCII fonts which are designed to be used with
+ Chinese, Japanese, Korean characters. When we use mixture of
+ such fonts and normal fonts (having correct `ascent' value), a
+ display line gets very ugly. Since we have no way to fix it
+ automatically, it is users responsibility to supply well designed
+ fonts or correct `ascent' value of fonts. But, the latter
+ requires heavy work (modifying all bitmap data in BDF files).
+ So, Emacs accepts a private font property
+ `_MULE_BASELINE_OFFSET'. If a font has this property, we
+ calculate the baseline position by subtracting the value from
+ `ascent'. In other words, the value indicates how many bits
+ higher we should draw a character of the font than normal ASCII
+ text for a better looking.
+
+ We also have to consider the fact that the concept of `baseline'
+ differs among languages to which each character belongs. For
+ instance, baseline should be at the bottom most position of all
+ glyphs for Chinese, Japanese, and Korean. But, many of existing
+ fonts for those characters doesn't have correct `ascent' values
+ because they are designed to be used with ASCII fonts. To
+ display characters of different language on the same line, the
+ best way will be to arrange them in the middle of the line. So,
+ in such a case, again, we utilize the font property
+ `_MULE_BASELINE_OFFSET'. If the value is larger than `ascent' we
+ calculate baseline so that a character is arranged in the middle
+ of a line. */
+
+ int baseline_offset;
+
+ /* Non zero means a character should be composed at a position
+ relative to the height (or depth) of previous glyphs in the
+ following cases:
+ (1) The bottom of the character is higher than this value. In
+ this case, the character is drawn above the previous glyphs.
+ (2) The top of the character is lower than 0 (i.e. baseline
+ height). In this case, the character is drawn beneath the
+ previous glyphs.
+
+ This value is take from a private font property
+ `_MULE_RELATIVE_COMPOSE' which is introduced by Emacs. */
+ int relative_compose;
+
+ /* CCL program to calculate code points of the font. */
+ struct ccl_program *font_encoder;
+};
+
+#define FONT_NOT_OPENED -1
+#define FONT_NOT_FOUND -2
+
+struct fontset_info
+{
+ /* Name of the fontset. */
+ char *name;
+
+ /* Size of the fontset. This is the same as the size of ASCII font
+ of this fontset. */
+ int size;
+
+ /* Height of the tallest font in the fontset. */
+ int height;
+
+ /* Table of font name for each character set. */
+ char *fontname[MAX_CHARSET];
+
+ /* Table of index numbers of fonts indexed by charset. If a font is
+ not yet loaded, the value is -1 (FONT_NOT_OPENED). If font
+ loading is failed, the value is -2 (FONT_NOT_FOUND). */
+ int font_indexes[MAX_CHARSET];
+};
+
+/* This data type is used for the fontset_data field of struct frame. */
+
+struct fontset_data
+{
+ /* A table of pointers to all the fontsets. */
+ struct fontset_info **fontset_table;
+
+ /* The current capacity of fontset_table. */
+ int fontset_table_size;
+
+ /* The number of fontsets actually stored in fontset_table.
+ fontset_table[n] is used and valid iff 0 <= n < n_fontsets.
+ 0 <= n_fontsets <= fontset_table_size. */
+ int n_fontsets;
+};
+
+/* The following six are window system dependent functions.
+ Initialization routine of each window system should set appropriate
+ functions to these variables. For instance, in case of X window,
+ x_term_init does this. */
+
+/* Return a pointer to struct font_info of font FONT_IDX of frame F. */
+extern struct font_info *(*get_font_info_func) (/* FRAME_PTR f;
+ int font_idx */);
+
+/* Return a list of font names which matches PATTERN. See the document of
+ `x-list-fonts' for more detail. */
+extern Lisp_Object (*list_fonts_func) (/* Lisp_Object pattern, face, frame,
+ width */);
+
+/* Load a font named NAME for frame F and return a pointer to the
+ information of the loaded font. If loading is failed, return -1. */
+extern struct font_info *(*load_font_func) (/* FRAME_PTR f; char *name */);
+
+/* Return a pointer to struct font_info of a font named NAME for frame F.
+ If no such font is loaded, return NULL. */
+extern struct font_info *(*query_font_func) (/* FRAME_PTR f; char *name */);
+
+/* Additional function for setting fontset or changing fontset
+ contents of frame F. This function may change the coordinate of
+ the frame. */
+extern void (*set_frame_fontset_func) (/* FRAME_PTR f; Lisp_Object arg, oldval */);
+
+/* Check if any window system is used now. */
+extern void (*check_window_system_func) ();
+
+extern struct fontset_data *alloc_fontset_data ();
+extern void free_fontset_data ();
+extern struct font_info *fs_load_font ();
+extern Lisp_Object list_fontsets ();
+extern Lisp_Object Vglobal_fontset_alist;
+
+extern Lisp_Object Qfontset;
+
+#endif /* _FONTSET_H */
projects / emacs.git / commitdiff