diff options
45 files changed, 21931 insertions, 0 deletions
diff --git a/lisp/gnus/gnus-mule.el b/lisp/gnus/gnus-mule.el new file mode 100644 index 00000000000..b7abab722d3 --- /dev/null +++ b/lisp/gnus/gnus-mule.el @@ -0,0 +1,179 @@ +;; 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 diff --git a/lisp/international/ccl.el b/lisp/international/ccl.el new file mode 100644 index 00000000000..da2f1585d87 --- /dev/null +++ b/lisp/international/ccl.el @@ -0,0 +1,1106 @@ +;; 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. + +;;;###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 diff --git a/lisp/international/characters.el b/lisp/international/characters.el new file mode 100644 index 00000000000..8ce6e4b5638 --- /dev/null +++ b/lisp/international/characters.el @@ -0,0 +1,388 @@ +;;; 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.") + + +;;; 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 ?\$A!2(B "($A!3(B") +(modify-syntax-entry ?\$A!4(B "($A!5(B") +(modify-syntax-entry ?\$A!6(B "($A!7(B") +(modify-syntax-entry ?\$A!8(B "($A!9(B") +(modify-syntax-entry ?\$A!:(B "($A!;(B") +(modify-syntax-entry ?\$A!<(B "($A!=(B") +(modify-syntax-entry ?\$A!>(B "($A!?(B") +(modify-syntax-entry ?\$A!3(B ")$A!2(B") +(modify-syntax-entry ?\$A!5(B ")$A!4(B") +(modify-syntax-entry ?\$A!7(B ")$A!6(B") +(modify-syntax-entry ?\$A!9(B ")$A!8(B") +(modify-syntax-entry ?\$A!;(B ")$A!:(B") +(modify-syntax-entry ?\$A!=(B ")$A!<(B") +(modify-syntax-entry ?\$A!?(B ")$A!>(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 ?,L-(B ".") +(modify-syntax-entry ?,Lp(B ".") +(modify-syntax-entry ?,L}(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 ',A@(B' to ',A(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 ?,AW(B "_") + (modify-syntax-entry ?,Aw(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 '(?,B!(B ?,B#(B ?,B%(B ?,B&(B ?,B)(B ?,B*(B ?,B+(B ?,B,(B ?,B.(B ?,B/(B ?,B1(B ?,B3(B ?,B5(B ?,B6(B ?,B9(B ?,B:(B ?,B;(B ?,B<(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 ?,BW(B ".") +(modify-syntax-entry ?,Bw(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 ?,F7(B ".") +(modify-syntax-entry ?,F;(B ".") +(modify-syntax-entry ?,F=(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 '(?$B!<(B ?$B!+(B ?$B!,(B ?$B!3(B ?$B!4(B ?$B!5(B ?$B!6(B ?$B!7(B ?$B!8(B ?$B!9(B ?$B!:(B ?$B!;(B))) + (while chars + (modify-syntax-entry (car chars) "w") + (setq chars (cdr chars)))) +(modify-syntax-entry ?\$B!J(B "($B!K(B") +(modify-syntax-entry ?\$B!N(B "($B!O(B") +(modify-syntax-entry ?\$B!P(B "($B!Q(B") +(modify-syntax-entry ?\$B!V(B "($B!W(B") +(modify-syntax-entry ?\$B!X(B "($B!Y(B") +(modify-syntax-entry ?\$B!K(B ")$B!J(B") +(modify-syntax-entry ?\$B!O(B ")$B!N(B") +(modify-syntax-entry ?\$B!Q(B ")$B!P(B") +(modify-syntax-entry ?\$B!W(B ")$B!V(B") +(modify-syntax-entry ?\$B!Y(B ")$B!X(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 '(?$B!<(B ?$B!+(B ?$B!,(B))) + (while chars + (modify-category-entry (car chars) ?K) + (modify-category-entry (car chars) ?H) + (setq chars (cdr chars)))) +(let ((chars '(?$B!3(B ?$B!4(B ?$B!5(B ?$B!6(B ?$B!7(B ?$B!8(B ?$B!9(B ?$B!:(B ?$B!;(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 '(?(I!(B ?(I"(B ?(I#(B ?(I$(B ?(I%(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 + (",T!(B-,TCEG(B-,TN(B" "w" ?0) ; consonant + (",TDFPRS`(B-,Te(B" "w" ?1) ; vowel base + (",TQT(B-,TWgn(B" "w" ?2) ; vowel upper + (",TX(B-,TZ(B" "w" ?3) ; vowel lower + (",Th(B-,Tm(B" "w" ?4) ; tone mark + (",TOfp(B-,Ty(B" "w" ?0) ; digit and misc + (",T_oz{(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. + ) + + +;;; 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 + )) diff --git a/lisp/international/encoded-kb.el b/lisp/international/encoded-kb.el new file mode 100644 index 00000000000..2861fc45148 --- /dev/null +++ b/lisp/international/encoded-kb.el @@ -0,0 +1,285 @@ +;; 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 diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el new file mode 100644 index 00000000000..65519590cc3 --- /dev/null +++ b/lisp/international/fontset.el @@ -0,0 +1,336 @@ +;;; 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)))) + + +;; 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 diff --git a/lisp/international/isearch-x.el b/lisp/international/isearch-x.el new file mode 100644 index 00000000000..fb288d16d9c --- /dev/null +++ b/lisp/international/isearch-x.el @@ -0,0 +1,76 @@ +;;; 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 diff --git a/lisp/international/kinsoku.el b/lisp/international/kinsoku.el new file mode 100644 index 00000000000..a26f61c997a --- /dev/null +++ b/lisp/international/kinsoku.el @@ -0,0 +1,141 @@ +;;; 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 + "$B!"!#!$!%!&!'!(!)!*!+!,!-!.!/!0!1!2!3!4!5!6!7!8!9!:!;!<!=!>(B\ +$B!?!@!A!B!C!D!E!G!I!K!M!O!Q!S!U!W!Y![!k!l!m!n(B\ +$B$!$#$%$'$)$C$c$e$g$n%!%#%%%'%)%C%c%e%g%n%u%v(B" + ;; Chinese GB2312 + "$A!"!##.#,!$!%!&!'!(!)!*!+!,!-!/!1#)!3!5!7!9!;!=(B\ +$A!?#;#:#?#!!@!A!B!C!c!d!e!f#/#\#"#_#~#|(e(B" + ;; Chinese BIG5 + "$(0!"!#!$!%!&!'!(!)!*!+!,!-!.!/!0!1!2(B\ +$(0!3!4!5!6!7!8!9!:!;!<!=!?!A!C!E!G!I!K(B\ +$(0!M!O!Q(B $(0!S!U!W!Y![!]!_!a!c!e!g!i!k!q(B\ +$(0"#"$"%"&"'"(")"*"+","2"3"4"j"k"l"x%7(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 + "$B!F!H!J!L!N!P!R!T!V!X!Z!k!l!m!n!w!x(B\ +$A!.!0#"#(!2!4!6!8!:!<!>!c!d!e#@!f!l(B" + ;; Chinese GB2312 + "$A(E(F(G(H(I(J(K(L(M(N(O(P(Q(R(S(T(U(V(W(X(Y(h(B\ +$(0!>!@!B!D!F!H!J!L!N!P!R!T!V!X!Z!\!^!`!b(B" + ;; Chinese BIG5 + "$(0!d!f!h!j!k!q!p"i"j"k"n"x$u$v$w$x$y$z${(B\ +$(0$|$}$~%!%"%#%$%%%&%'%(%)%*%+%:(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 diff --git a/lisp/international/kkc.el b/lisp/international/kkc.el new file mode 100644 index 00000000000..d004b88e58a --- /dev/null +++ b/lisp/international/kkc.el @@ -0,0 +1,586 @@ +;; 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 "$B4A(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 diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el new file mode 100644 index 00000000000..ebc9663dcb0 --- /dev/null +++ b/lisp/international/mule-cmds.el @@ -0,0 +1,494 @@ +;;; 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))) + + +;;; 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))) + +;;; 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.") + + +;;; 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))))))))) + +;;; 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 diff --git a/lisp/international/mule-diag.el b/lisp/international/mule-diag.el new file mode 100644 index 00000000000..ecee2b4615e --- /dev/null +++ b/lisp/international/mule-diag.el @@ -0,0 +1,565 @@ +;; 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))))) + + +;;; 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)))) + )) + +;;; 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))))) + + +;;; 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)) + )) + + +;;; 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)) + diff --git a/lisp/international/mule-util.el b/lisp/international/mule-util.el new file mode 100644 index 00000000000..27c64aa3a2b --- /dev/null +++ b/lisp/international/mule-util.el @@ -0,0 +1,419 @@ +;;; 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) + +;;; 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)) + + +;;; 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 diff --git a/lisp/international/mule.el b/lisp/international/mule.el new file mode 100644 index 00000000000..82c2679455a --- /dev/null +++ b/lisp/international/mule.el @@ -0,0 +1,529 @@ +;;; 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 diff --git a/lisp/international/quail.el b/lisp/international/quail.el new file mode 100644 index 00000000000..e44767a7e4d --- /dev/null +++ b/lisp/international/quail.el @@ -0,0 +1,1522 @@ +;;; 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 diff --git a/lisp/international/skkdic-cnv.el b/lisp/international/skkdic-cnv.el new file mode 100644 index 00000000000..4f227204bdc --- /dev/null +++ b/lisp/international/skkdic-cnv.el @@ -0,0 +1,561 @@ +;; 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 ($B2>L>J8(B +;; $B;zNs(B) can be converted to one of CONVi. CONVi is a Kanji ($B4A;z(B) +;; and Kana ($B2>L>(B) mixed string. +;; +;; KANASTRING may have a trailing ASCII letter for Okurigana ($BAw$j2>L>(B) +;; information. For instance, the trailing letter `k' means that one +;; of the following Okurigana is allowed: $B$+$-$/$1$3(B. So, in that +;; case, the string "KANASTRING$B$/(B" can be converted to one of "CONV1$B$/(B", +;; CONV2$B$/(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 + '(("$B$$$-(B" "$B9T(B") + ("$B$,$+$j(B" "$B78(B") + ("$B$,$/(B" "$B3X(B") + ("$B$,$o(B" "$B@n(B") + ("$B$7$c(B" "$B<R(B") + ("$B$7$e$&(B" "$B=8(B") + ("$B$7$g$&(B" "$B>^(B" "$B>k(B") + ("$B$8$g$&(B" "$B>k(B") + ("$B$;$s(B" "$B@~(B") + ("$B$@$1(B" "$B3Y(B") + ("$B$A$c$/(B" "$BCe(B") + ("$B$F$s(B" "$BE9(B") + ("$B$H$&$2(B" "$BF=(B") + ("$B$I$*$j(B" "$BDL$j(B") + ("$B$d$^(B" "$B;3(B") + ("$B$P$7(B" "$B66(B") + ("$B$O$D(B" "$BH/(B") + ("$B$b$/(B" "$BL\(B") + ("$B$f$-(B" "$B9T(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 ?$B!<(B) ; `$B!<(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 diff --git a/lisp/international/skkdic-utl.el b/lisp/international/skkdic-utl.el new file mode 100644 index 00000000000..d5b0c1e6149 --- /dev/null +++ b/lisp/international/skkdic-utl.el @@ -0,0 +1,198 @@ +;; 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 + '((?$B$!(B . ?a) (?$B$"(B . ?a) (?$B$#(B . ?i) (?$B$$(B . ?i) (?$B$%(B . ?u) + (?$B$&(B . ?u) (?$B$'(B . ?e) (?$B$((B . ?e) (?$B$)(B . ?o) (?$B$*(B . ?o) + (?$B$+(B . ?k) (?$B$,(B . ?g) (?$B$-(B . ?k) (?$B$.(B . ?g) (?$B$/(B . ?k) + (?$B$0(B . ?g) (?$B$1(B . ?k) (?$B$2(B . ?g) (?$B$3(B . ?k) (?$B$4(B . ?g) + (?$B$5(B . ?s) (?$B$6(B . ?z) (?$B$7(B . ?s) (?$B$8(B . ?j) (?$B$9(B . ?s) + (?$B$:(B . ?z) (?$B$;(B . ?s) (?$B$<(B . ?z) (?$B$=(B . ?s) (?$B$>(B . ?z) + (?$B$?(B . ?t) (?$B$@(B . ?d) (?$B$A(B . ?t) (?$B$B(B . ?d) (?$B$C(B . ?t) + (?$B$D(B . ?t) (?$B$E(B . ?d) (?$B$F(B . ?t) (?$B$G(B . ?d) (?$B$H(B . ?t) (?$B$I(B . ?d) + (?$B$J(B . ?n) (?$B$K(B . ?n) (?$B$L(B . ?n) (?$B$M(B . ?n) (?$B$N(B . ?n) + (?$B$O(B . ?h) (?$B$P(B . ?b) (?$B$Q(B . ?p) (?$B$R(B . ?h) (?$B$S(B . ?b) + (?$B$T(B . ?p) (?$B$U(B . ?h) (?$B$V(B . ?b) (?$B$W(B . ?p) (?$B$X(B . ?h) + (?$B$Y(B . ?b) (?$B$Z(B . ?p) (?$B$[(B . ?h) (?$B$\(B . ?b) (?$B$](B . ?p) + (?$B$^(B . ?m) (?$B$_(B . ?m) (?$B$`(B . ?m) (?$B$a(B . ?m) (?$B$b(B . ?m) + (?$B$c(B . ?y) (?$B$d(B . ?y) (?$B$e(B . ?y) (?$B$f(B . ?y) (?$B$g(B . ?y) (?$B$h(B . ?y) + (?$B$i(B . ?r) (?$B$j(B . ?r) (?$B$k(B . ?r) (?$B$l(B . ?r) (?$B$m(B . ?r) + (?$B$o(B . ?w) (?$B$p(B . ?w) (?$B$q(B . ?w) (?$B$r(B . ?w) + (?$B$s(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 ?$B$"(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 `$B!<(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 ?$B!<(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 diff --git a/lisp/international/titdic-cnv.el b/lisp/international/titdic-cnv.el new file mode 100644 index 00000000000..382a666735f --- /dev/null +++ b/lisp/international/titdic-cnv.el @@ -0,0 +1,403 @@ +;;; 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 "[:$A!K$(0!(!J(B]+\\([^:$A!K$(0!(!K(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 diff --git a/lisp/language/china-util.el b/lisp/language/china-util.el new file mode 100644 index 00000000000..902919db440 --- /dev/null +++ b/lisp/language/china-util.el @@ -0,0 +1,155 @@ +;; 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 diff --git a/lisp/language/chinese.el b/lisp/language/chinese.el new file mode 100644 index 00000000000..5e90963d11b --- /dev/null +++ b/lisp/language/chinese.el @@ -0,0 +1,236 @@ +;;; 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 ($AVPND(B,$AFUM(;0(B,$A::So(B) $ADc:C(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 ($(0GnM$(B,$(0N]0*Hd(B) $(0*/=((B, $(0+$)p(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 diff --git a/lisp/language/cyrillic.el b/lisp/language/cyrillic.el new file mode 100644 index 00000000000..1ff084a5362 --- /dev/null +++ b/lisp/language/cyrillic.el @@ -0,0 +1,71 @@ +;;; 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 (,L@caaZXY(B) ,L7T`PRabRcYbU(B!"))) + +;;; cyrillic.el ends here diff --git a/lisp/language/devan-util.el b/lisp/language/devan-util.el new file mode 100644 index 00000000000..9bdffa4586e --- /dev/null +++ b/lisp/language/devan-util.el @@ -0,0 +1,1160 @@ +;;; 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 ($(5!3!4!5!6!7!8!9!:!;!<!=!>!?!@!A!B!C!D!E(B +;; $(5!F!G!H!I!J!K!L!M!N!O!P!Q!R!S!T!U!V!W!X(B) +;; N - Nukta ($(5!i(B) +;; H - Halant($(5!h(B) +;; V - Vowel ($(5!$!%!&!'!(!)!*!+!,!-!.!/!0!1!2(B) +;; D - Vowel Modifiers, i.e. Anuswar, Chandrabindu, Visarg ($(5!!!"(B) +;; M - Matra ($(5!Z![!\!]!^!_!`!a!b!c!d!e!f!g(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 + "\\(\\([$(5!3(B-$(5!X(B]$(5!i(B?$(5!h(B\\)?\\([$(5!3(B-$(5!X(B]$(5!i(B?$(5!h(B\\)?[$(5!3(B-$(5!X(B]$(5!i(B?$(5!h(B\\)?[$(5!3(B-$(5!X(B]$(5!i(B?[$(5!Z(B-$(5!g(B]?[$(5!!!"(B]?" + "Regexp matching to one Devanagari consonant syllable.") + +(defconst devanagari-cons-syllable-incomplete-examine + "\\([$(5!3(B-$(5!X(B]$(5!i(B?$(5!h(B\\)?\\([$(5!3(B-$(5!X(B]$(5!i(B?$(5!h(B\\)?[$(5!3(B-$(5!X(B]$(5!i(B?$(5!h(B$" + "Regexp matching to one Devanagari incomplete consonant syllable.") + +(defconst devanagari-vowel-syllable-examine + "[$(5!$(B-$(5!2(B][$(5!!!"!#(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 + "[$(5!q(B-$(5!z!j(B]") +(defconst devanagari-other-sign-examine + "[$(5!!!j(B]$(5!i(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 "$(5!X" . "$(5",(B") + ("\\($(5!O!^(B\\)" . "$(5"-(B") + ("\\($(5!P!](B\\)" . "$(5".(B") + ("\\($(5!P!^(B\\)" . "$(5"/(B") + + ;; `r' at the top of syllable and followed by other consonants. + ;; ("[^$(5!h(B]\\($(5!O!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"p(B") + ("^\\($(5!O!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"p(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. + + ("\\($(5!:!i!h!O(B\\)" . "$(5"!(B") + ("\\($(5!I!i!h!O(B\\)" . "$(5""(B") + ("\\($(5!3!h!O(B\\)" . "$(5"#(B") + ("\\($(5!:!h!O(B\\)" . "$(5"$(B") + ("\\($(5!B!h!O(B\\)" . "$(5"%(B") + ("\\($(5!H!h!O(B\\)" . "$(5"&(B") + ("\\($(5!I!h!O(B\\)" . "$(5"'(B") + ("\\($(5!U!h!O(B\\)" . "$(5"((B") + ("\\($(5!W!h!O(B\\)" . "$(5")(B") + + ;; Ligature Rules + ("\\($(5!3!h!B!h!O!h!M(B\\)" . "$(5$!(B") + ("\\($(5!3!h!B!h!T(B\\)" . "$(5$"(B") + ("\\($(5!3!h!B!h!M(B\\)" . "$(5$#(B") + ("\\($(5!3!h!F!h!M(B\\)" . "$(5$$(B") + ("\\($(5!3!h!O!h!M(B\\)" . "$(5$%(B") + ("\\($(5!3!h!T!h!M(B\\)" . "$(5$&(B") + ("\\($(5!3!h!3(B\\)" . "$(5$'(B") + ("\\($(5!3!h!B(B\\)" . "$(5$((B") + ("\\($(5!3!h!F(B\\)" . "$(5$)(B") + ("\\($(5!3!h!L(B\\)" . "$(5$*(B") + ("\\($(5!3!h!M(B\\)" . "$(5$+(B") + ("\\($(5!3!h!Q(B\\)" . "$(5$,(B") + ("\\($(5!3!h!T(B\\)" . "$(5$-(B") + ("\\($(5!3!h!V(B\\)" . "$(5$.(B") + ("\\($(5!6!h!F(B\\)" . "$(5$/(B") + ("\\($(5!7!h!3!h!B!h!M(B\\)" . "$(5$0(B") + ("\\($(5!7!h!3!h!V!h!T(B\\)" . "$(5$1(B") + ("\\($(5!7!h!3!h!B(B\\)" . "$(5$2(B") + ("\\($(5!7!h!3!h!V(B\\)" . "$(5$3(B") + ("\\($(5!7!h!6!h!O(B\\)" . "$(5$4(B") + ("\\($(5!7!h!3!h!M(B\\)" . "$(5$5(B") + ("\\($(5!7!h!4!h!M(B\\)" . "$(5$6(B") + ("\\($(5!7!h!5!h!M(B\\)" . "$(5$7(B") + ("\\($(5!7!h!6!h!M(B\\)" . "$(5$8(B") + ("\\($(5!7!h!3(B\\)" . "$(5$9(B") + ("\\($(5!7!h!4(B\\)" . "$(5$:(B") + ("\\($(5!7!h!5(B\\)" . "$(5$;(B") + ("\\($(5!7!h!6(B\\)" . "$(5$<(B") + ("\\($(5!7!h!7(B\\)" . "$(5$=(B") + ("\\($(5!7!h!F(B\\)" . "$(5$>(B") + ("\\($(5!7!h!L(B\\)" . "$(5$?(B") + ("\\($(5!7!h!M(B\\)" . "$(5$@(B") + ("\\($(5!8!h!8(B\\)" . "$(5$A(B") + ("\\($(5!8!h!<(B\\)" . "$(5$B(B") + ("\\($(5!9!h!M(B\\)" . "$(5$C(B") + ("\\($(5!:!h!O(B\\)" . "$(5$D(B") + ("\\($(5!:!h!h(B\\)" . "$(5$E(B") + ("\\($(5!<!h!8(B\\)" . "$(5$F(B") + ("\\($(5!<!h!:(B\\)" . "$(5$G(B") + ("\\($(5!=!h!3(B\\)" . "$(5$H(B") + ("\\($(5!=!h!=(B\\)" . "$(5$I(B") + ("\\($(5!=!h!>(B\\)" . "$(5$J(B") + ("\\($(5!=!h!M(B\\)" . "$(5$K(B") + ("\\($(5!>!h!M(B\\)" . "$(5$L(B") + ("\\($(5!?!h!5!h!M(B\\)" . "$(5$M(B") + ("\\($(5!?!h!6!h!O(B\\)" . "$(5$N(B") + ("\\($(5!?!h!O!h!M(B\\)" . "$(5$O(B") + ("\\($(5!?!h!5(B\\)" . "$(5$P(B") + ("\\($(5!?!h!6(B\\)" . "$(5$Q(B") + ("\\($(5!?!h!?(B\\)" . "$(5$R(B") + ("\\($(5!?!h!L(B\\)" . "$(5$S(B") + ("\\($(5!?!h!M(B\\)" . "$(5$T(B") + ("\\($(5!@!h!M(B\\)" . "$(5$`(B") + ("\\($(5!B!h!B(B\\)" . "$(5$a(B") + ("\\($(5!B!h!F(B\\)" . "$(5$b(B") + ("\\($(5!D!h!D!h!M(B\\)" . "$(5$c(B") + ("\\($(5!D!h!E!h!M(B\\)" . "$(5$d(B") + ("\\($(5!D!h!K!h!M(B\\)" . "$(5$e(B") + ("\\($(5!D!h!O!h!M(B\\)" . "$(5$f(B") + ("\\($(5!D!h!T!h!M(B\\)" . "$(5$g(B") + ("\\($(5!D!h!5!h!O(B\\)" . "$(5$h(B") + ("\\($(5!D!h!6!h!O(B\\)" . "$(5$i(B") + ("\\($(5!D!h!D!h!T(B\\)" . "$(5$j(B") + ("\\($(5!D!h!E!h!T(B\\)" . "$(5$k(B") + ("\\($(5!D!h!5(B\\)" . "$(5$l(B") + ("\\($(5!D!h!6(B\\)" . "$(5$m(B") + ("\\($(5!D!h!D(B\\)" . "$(5$n(B") + ("\\($(5!D!h!E(B\\)" . "$(5$o(B") + ("\\($(5!D!h!F(B\\)" . "$(5$p(B") + ("\\($(5!D!h!J(B\\)" . "$(5$q(B") + ("\\($(5!D!h!K(B\\)" . "$(5$r(B") + ("\\($(5!D!h!L(B\\)" . "$(5$s(B") + ("\\($(5!D!h!M(B\\)" . "$(5$t(B") + ("\\($(5!D!h!T(B\\)" . "$(5$u(B") + ("\\($(5!E!h!F(B\\)" . "$(5$v(B") + ("\\($(5!F!h!F(B\\)" . "$(5$w(B") + ("\\($(5!H!h!B(B\\)" . "$(5$x(B") + ("\\($(5!H!h!F(B\\)" . "$(5$y(B") + ("\\($(5!H!h!Q(B\\)" . "$(5$z(B") + ("\\($(5!J!h!F(B\\)" . "$(5${(B") + ("\\($(5!J!h!J(B\\)" . "$(5$|(B") + ("\\($(5!J!h!T(B\\)" . "$(5$}(B") + ("\\($(5!K!h!F(B\\)" . "$(5$~(B") + ("\\($(5!L!h!F(B\\)" . "$(5#P(B") + ("\\($(5!L!h!Q(B\\)" . "$(5#Q(B") + ("\\($(5!Q!h!Q(B\\)" . "$(5#`(B") + ("\\($(5!T!h!F(B\\)" . "$(5#a(B") + ("\\($(5!T!h!T(B\\)" . "$(5#b(B") + ("\\($(5!U!h!8(B\\)" . "$(5#c(B") + ("\\($(5!U!h!F(B\\)" . "$(5#d(B") + ("\\($(5!U!h!J(B\\)" . "$(5#e(B") + ("\\($(5!U!h!Q(B\\)" . "$(5#f(B") + ("\\($(5!U!h!T(B\\)" . "$(5#g(B") + ("\\($(5!V!h!=!h!O!h!M(B\\)" . "$(5#h(B") + ("\\($(5!V!h!=!h!M(B\\)" . "$(5#i(B") + ("\\($(5!V!h!=!h!T(B\\)" . "$(5#j(B") + ("\\($(5!V!h!=(B\\)" . "$(5#k(B") + ("\\($(5!V!h!>(B\\)" . "$(5#l(B") + ("\\($(5!W!h!F(B\\)" . "$(5#m(B") + ("\\($(5!W!h!O(B\\)" . "$(5#n(B") + ("\\($(5!X!h!A(B\\)" . "$(5#p(B") + ("\\($(5!X!h!F(B\\)" . "$(5#q(B") + ("\\($(5!X!h!L(B\\)" . "$(5#r(B") + ("\\($(5!X!h!M(B\\)" . "$(5#s(B") + ("\\($(5!X!h!O(B\\)" . "$(5#t(B") + ("\\($(5!X!h!Q(B\\)" . "$(5#u(B") + ("\\($(5!X!h!T(B\\)" . "$(5#v(B") + ;; Special Ligature Rules + ("\\($(5!X!_(B\\)" . "$(5#R(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 + ("\\($(5!3!h!V!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"l(B") + ("\\($(5!:!h!<!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"m(B") + ;; ordinary forms + ("\\($(5!5!h!O!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"`(B") + ("\\($(5!6!h!F!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"a(B") + ;; ("\\($(5!<!h!8!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"c(B") ; Mistake, must check later. + ("\\($(5!B!h!B!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"c(B") + ("\\($(5!B!h!O!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"d(B") + ("\\($(5!E!h!F!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"e(B") + ("\\($(5!E!h!O!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"f(B") + ("\\($(5!H!h!B!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"g(B") + ("\\($(5!U!h!8!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"h(B") + ("\\($(5!U!h!O!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"i(B") + ("\\($(5!U!h!T!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"j(B") + ;; ("\\($(5!U!h!T!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"k(B") ; must check later. + ;; Conjunction form associated with Nukta sign. + ("\\($(5!3!i!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"s(B") + ("\\($(5!4!i!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"t(B") + ("\\($(5!5!i!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"u(B") + ("\\($(5!:!i!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"z(B") + ("\\($(5!I!i!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"y(B") + + ;; For consonants other than listed above, glyph-composition will + ;; be applied. If the consonant which is preceding "$(5!O(B" does not + ;; have the vertical line (such as "$(5!?(B"), "$(5"r(B" is put beneath the + ;; consonant. + ;; + ;; ("cons-not-yet-listed-up\\($(5!h!O(B\\)" . "$(5"q(B") + ("[$(5!7!9!=!>!?!@!D!O!P!R!S!X(B]\\($(5!h!O(B\\)" . "$(5"r(B") + ("$(5!?!i(B\\($(5!h!O(B\\)" . "$(5"r(B") + ("$(5!@!i(B\\($(5!h!O(B\\)" . "$(5"r(B") + + ;; Nukta + ("\\($(5!!!i(B\\)" . "$(5#!(B") + ("\\($(5!&!i(B\\)" . "$(5#&(B") + ("\\($(5!'!i(B\\)" . "$(5#'(B") + ("\\($(5!*!i(B\\)" . "$(5#*(B") + ("\\($(5!3!i(B\\)" . "$(5#3(B") + ("\\($(5!4!i(B\\)" . "$(5#4(B") + ("\\($(5!5!i(B\\)" . "$(5#5(B") + ("\\($(5!:!i(B\\)" . "$(5#:(B") + ("\\($(5!?!i(B\\)" . "$(5#?(B") + ("\\($(5!@!i(B\\)" . "$(5#@(B") + ("\\($(5!I!i(B\\)" . "$(5#I(B") + ("\\($(5!j!i(B\\)" . "$(5#J(B") + + ;; Half forms. + ("\\($(5!3!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"3(B") + ("\\($(5!4!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"4(B") + ("\\($(5!5!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"5(B") + ("\\($(5!6!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"6(B") + ("\\($(5!8!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"8(B") + ("\\($(5!:!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5":(B") + ("\\($(5!;!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5";(B") + ("\\($(5!<!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"<(B") + ("\\($(5!A!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"A(B") + ("\\($(5!B!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"B(B") + ("\\($(5!C!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"C(B") + ("\\($(5!E!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"E(B") + ("\\($(5!F!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"F(B") + ("\\($(5!G!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"G(B") + ("\\($(5!H!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"H(B") + ("\\($(5!I!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"I(B") + ("\\($(5!J!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"J(B") + ("\\($(5!K!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"K(B") + ("\\($(5!L!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"L(B") + ("\\($(5!M!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"M(B") + ("\\($(5!N!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"N(B") + ("\\($(5!Q!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"Q(B") + ("\\($(5!R!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"R(B") + ("\\($(5!S!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"S(B") + ("\\($(5!T!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"T(B") + ("\\($(5!U!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"U(B") + ("\\($(5!V!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"V(B") + ("\\($(5!W!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"W(B") + ) + "Alist of regexps of Devanagari character sequences vs composed characters.") + +;; Example: +;;("\\($(5!F!h(B\\)[$(5!3(B-$(5!X(B]" . "$(5"F(B") +;;(string-match "\\($(5!F!h(B\\)[$(5!3(B-$(5!X(B]" "$(5!X) + (?$(5!^(B 40 (bc . tc)) + (?$(5!_(B 40 (bc . tc)) + (?$(5!`(B 40 (tc . bc)) + (?$(5!a(B 40 (tc . bc)) + (?$(5!b(B 40 (tc . bc)) + (?$(5!c(B 40 (tc . bc)) + (?$(5!d(B 40) + (?$(5!e(B 40) + (?$(5!f(B 40) + (?$(5!g(B 40) + (?$(5!h(B 0 (br . tr)) ; Halant's special treatment. + (?$(5!i(B 0 (br . tr)) ; Nukta's special treatment. + (?$(5!j(B 0) + (nil 0) + (nil 0) + (nil 0) + (nil 0) + (nil 0) + (nil 0) + (?$(5!q(B 0) + (?$(5!r(B 0) + (?$(5!s(B 0) + (?$(5!t(B 0) + (?$(5!u(B 0) + (?$(5!v(B 0) + (?$(5!w(B 0) + (?$(5!x(B 0) + (?$(5!y(B 0) + (?$(5!z(B 0) + (nil 0) + (nil 0) + (nil 0) + (nil 0) + (?$(5"!(B 0) + (?$(5""(B 0) + (?$(5"#(B 0) + (?$(5"$(B 0) + (?$(5"%(B 0) + (?$(5"&(B 0) + (?$(5"'(B 0) + (?$(5"((B 0) + (?$(5")(B 0) + (?$(5"*(B 0) + (?$(5"+(B 0) + (?$(5",(B 0) + (?$(5"-(B 0) + (?$(5".(B 0) + (?$(5"/(B 0) + (?$(5"0(B 0) + (?$(5"1(B 0) + (?$(5"2(B 0) + (?$(5"3(B 0) + (?$(5"4(B 0) + (?$(5"5(B 0) + (?$(5"6(B 0) + (?$(5"7(B 0) + (?$(5"8(B 0) + (?$(5"9(B 0) + (?$(5":(B 0) + (?$(5";(B 0) + (?$(5"<(B 0) + (?$(5"=(B 0) + (?$(5">(B 0) + (?$(5"?(B 0) + (?$(5"@(B 0) + (?$(5"A(B 0) + (?$(5"B(B 0) + (?$(5"C(B 0) + (?$(5"D(B 0) + (?$(5"E(B 0) + (?$(5"F(B 0) + (?$(5"G(B 0) + (?$(5"H(B 0) + (?$(5"I(B 0) + (?$(5"J(B 0) + (?$(5"K(B 0) + (?$(5"L(B 0) + (?$(5"M(B 0) + (?$(5"N(B 0) + (?$(5"O(B 0) + (?$(5"P(B 0) + (?$(5"Q(B 0) + (?$(5"R(B 0) + (?$(5"S(B 0) + (?$(5"T(B 0) + (?$(5"U(B 0) + (?$(5"V(B 0) + (?$(5"W(B 0) + (?$(5"X(B 0) + (?$(5"Y(B 0) + (?$(5"Z(B 0) + (?$(5"[(B 0) + (?$(5"\(B 0) + (?$(5"](B 0) + (?$(5"^(B 0) + (?$(5"_(B 0) + (?$(5"`(B 0) + (?$(5"a(B 0) + (?$(5"b(B 0) + (?$(5"c(B 0) + (?$(5"d(B 0) + (?$(5"e(B 0) + (?$(5"f(B 0) + (?$(5"g(B 0) + (?$(5"h(B 0) + (?$(5"i(B 0) + (?$(5"j(B 0) + (?$(5"k(B 0) + (?$(5"l(B 0) + (?$(5"m(B 0) + (?$(5"n(B 0) + (?$(5"o(B 0) + (?$(5"p(B 20 (tr . br)) + (?$(5"q(B 20 (br . tr)) + (?$(5"r(B 20 (br . tr)) + (?$(5"s(B 0) + (?$(5"t(B 0) + (?$(5"u(B 0) + (?$(5"v(B 0) + (?$(5"w(B 0) + (?$(5"x(B 0) + (?$(5"y(B 0) + (?$(5"z(B 0) + (?$(5"{(B 0) + (?$(5"|(B 0) + (?$(5"}(B 0) + (?$(5"~(B 0) + (?$(5#!(B 0) + (?$(5#"(B 0) + (?$(5##(B 0) + (?$(5#$(B 0) + (?$(5#%(B 0) + (?$(5#&(B 0) + (?$(5#'(B 0) + (?$(5#((B 0) + (?$(5#)(B 0) + (?$(5#*(B 0) + (?$(5#+(B 0) + (?$(5#,(B 0) + (?$(5#-(B 0) + (?$(5#.(B 0) + (?$(5#/(B 0) + (?$(5#0(B 0) + (?$(5#1(B 0) + (?$(5#2(B 0) + (?$(5#3(B 0) + (?$(5#4(B 0) + (?$(5#5(B 0) + (?$(5#6(B 0) + (?$(5#7(B 0) + (?$(5#8(B 0) + (?$(5#9(B 0) + (?$(5#:(B 0) + (?$(5#;(B 0) + (?$(5#<(B 0) + (?$(5#=(B 0) + (?$(5#>(B 0) + (?$(5#?(B 0) + (?$(5#@(B 0) + (?$(5#A(B 0) + (?$(5#B(B 0) + (?$(5#C(B 0) + (?$(5#D(B 0) + (?$(5#E(B 0) + (?$(5#F(B 0) + (?$(5#G(B 0) + (?$(5#H(B 0) + (?$(5#I(B 0) + (?$(5#J(B 0) + (?$(5#K(B 0) + (?$(5#L(B 0) + (?$(5#M(B 0) + (?$(5#N(B 0) + (?$(5#O(B 0) + (?$(5#P(B 0) + (?$(5#Q(B 0) + (?$(5#R(B 0) + (?$(5#S(B 0) + (?$(5#T(B 0) + (?$(5#U(B 0) + (?$(5#V(B 0) + (?$(5#W(B 0) + (?$(5#X(B 0) + (?$(5#Y(B 0) + (?$(5#Z(B 0) + (?$(5#[(B 0) + (?$(5#\(B 0) + (?$(5#](B 0) + (?$(5#^(B 0) + (?$(5#_(B 0) + (?$(5#`(B 0) + (?$(5#a(B 0) + (?$(5#b(B 0) + (?$(5#c(B 0) + (?$(5#d(B 0) + (?$(5#e(B 0) + (?$(5#f(B 0) + (?$(5#g(B 0) + (?$(5#h(B 0) + (?$(5#i(B 0) + (?$(5#j(B 0) + (?$(5#k(B 0) + (?$(5#l(B 0) + (?$(5#m(B 0) + (?$(5#n(B 0) + (?$(5#o(B 0) + (?$(5#p(B 0) + (?$(5#q(B 0) + (?$(5#r(B 0) + (?$(5#s(B 0) + (?$(5#t(B 0) + (?$(5#u(B 0) + (?$(5#v(B 0) + (?$(5#w(B 0) + (?$(5#x(B 0) + (?$(5#y(B 0) + (?$(5#z(B 0) + (?$(5#{(B 0) + (?$(5#|(B 0) + (?$(5#}(B 0) + (?$(5#~(B 0) + (?$(5$!(B 0) + (?$(5$"(B 0) + (?$(5$#(B 0) + (?$(5$$(B 0) + (?$(5$%(B 0) + (?$(5$&(B 0) + (?$(5$'(B 0) + (?$(5$((B 0) + (?$(5$)(B 0) + (?$(5$*(B 0) + (?$(5$+(B 0) + (?$(5$,(B 0) + (?$(5$-(B 0) + (?$(5$.(B 0) + (?$(5$/(B 0) + (?$(5$0(B 0) + (?$(5$1(B 0) + (?$(5$2(B 0) + (?$(5$3(B 0) + (?$(5$4(B 0) + (?$(5$5(B 0) + (?$(5$6(B 0) + (?$(5$7(B 0) + (?$(5$8(B 0) + (?$(5$9(B 0) + (?$(5$:(B 0) + (?$(5$;(B 0) + (?$(5$<(B 0) + (?$(5$=(B 0) + (?$(5$>(B 0) + (?$(5$?(B 0) + (?$(5$@(B 0) + (?$(5$A(B 0) + (?$(5$B(B 0) + (?$(5$C(B 0) + (?$(5$D(B 0) + (?$(5$E(B 0) + (?$(5$F(B 0) + (?$(5$G(B 0) + (?$(5$H(B 0) + (?$(5$I(B 0) + (?$(5$J(B 0) + (?$(5$K(B 0) + (?$(5$L(B 0) + (?$(5$M(B 0) + (?$(5$N(B 0) + (?$(5$O(B 0) + (?$(5$P(B 0) + (?$(5$Q(B 0) + (?$(5$R(B 0) + (?$(5$S(B 0) + (?$(5$T(B 0) + (?$(5$U(B 0) + (?$(5$V(B 0) + (?$(5$W(B 0) + (?$(5$X(B 0) + (?$(5$Y(B 0) + (?$(5$Z(B 0) + (?$(5$[(B 0) + (?$(5$\(B 0) + (?$(5$](B 0) + (?$(5$^(B 0) + (?$(5$_(B 0) + (?$(5$`(B 0) + (?$(5$a(B 0) + (?$(5$b(B 0) + (?$(5$c(B 0) + (?$(5$d(B 0) + (?$(5$e(B 0) + (?$(5$f(B 0) + (?$(5$g(B 0) + (?$(5$h(B 0) + (?$(5$i(B 0) + (?$(5$j(B 0) + (?$(5$k(B 0) + (?$(5$l(B 0) + (?$(5$m(B 0) + (?$(5$n(B 0) + (?$(5$o(B 0) + (?$(5$p(B 0) + (?$(5$q(B 0) + (?$(5$r(B 0) + (?$(5$s(B 0) + (?$(5$t(B 0) + (?$(5$u(B 0) + (?$(5$v(B 0) + (?$(5$w(B 0) + (?$(5$x(B 0) + (?$(5$y(B 0) + (?$(5$z(B 0) + (?$(5${(B 0) + (?$(5$|(B 0) + (?$(5$}(B 0) + (?$(5$~(B 0) + )) + +;; Determine composition priority and rule of the array of Glyphs. +;; Sort the glyphs with their priority. + +;; Example: +;;(devanagari-reorder-glyph-for-composition '[?$(5"5(B ?$(5!X(B ?$(5![(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 "$(5"5!X![(B") => "2$(6!XP"5@![1(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 '(?$(5!6(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 + '( + (?$(5"p(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 diff --git a/lisp/language/devanagari.el b/lisp/language/devanagari.el new file mode 100644 index 00000000000..2f2ab1160aa --- /dev/null +++ b/lisp/language/devanagari.el @@ -0,0 +1,541 @@ +;;; 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 + ("$(5!!!"!#(B" "w" ?7) ; vowel-modifying diacritical mark + ; chandrabindu, anuswar, visarga + ("$(5!$(B-$(5!2(B" "w" ?5) ; independent vowel + ("$(5!3(B-$(5!X(B" "w" ?0) ; consonant + ("$(5!Z(B-$(5!g(B" "w" ?8) ; matra + ("$(5!q(B-$(5!z(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 $(5!!!"!#!$!%!&!'!(!)!*!+!,!-!.!/(B +;;2130 $(5!0!1!2!3!4!5!6!7!8!9!:!;!<!=!>!?(B +;;2140 $(5!@!A!B!C!D!E!F!G!H!I!J!K!L!M!N!O(B +;;2150 $(5!P!Q!R!S!T!U!V!W!X!Y!Z![!\!]!^!_(B +;;2160 $(5!`!a!b!c!d!e!f!g!h!i!j!k!l!m!n!o(B +;;2170 $(5!p!q!r!s!t!u!v!w!x!y!z!{!|!}!~(B +;; +;;2220 $(5"!"""#"$"%"&"'"(")"*"+","-"."/(B +;;2230 $(5"0"1"2"3"4"5"6"7"8"9":";"<"=">"?(B +;;2240 $(5"@"A"B"C"D"E"F"G"H"I"J"K"L"M"N"O(B +;;2250 $(5"P"Q"R"S"T"U"V"W"X"Y"Z"["\"]"^"_(B +;;2260 $(5"`"a"b"c"d"e"f"g"h"i"j"k"l"m"n"o(B +;;2270 $(5"p"q"r"s"t"u"v"w"x"y"z"{"|"}"~(B +;; +;;2320 $(5#!#"###$#%#&#'#(#)#*#+#,#-#.#/(B +;;2330 $(5#0#1#2#3#4#5#6#7#8#9#:#;#<#=#>#?(B +;;2340 $(5#@#A#B#C#D#E#F#G#H#I#J#K#L#M#N#O(B +;;2350 $(5#P#Q#R#S#T#U#V#W#X#Y#Z#[#\#]#^#_(B +;;2360 $(5#`#a#b#c#d#e#f#g#h#i#j#k#l#m#n#o(B +;;2370 $(5#p#q#r#s#t#u#v#w#x#y#z#{#|#}#~(B +;; +;;2420 $(5$!$"$#$$$%$&$'$($)$*$+$,$-$.$/(B +;;2430 $(5$0$1$2$3$4$5$6$7$8$9$:$;$<$=$>$?(B +;;2440 $(5$@$A$B$C$D$E$F$G$H$I$J$K$L$M$N$O(B +;;2450 $(5$P$Q$R$S$T$U$V$W$X$Y$Z$[$\$]$^$_(B +;;2460 $(5$`$a$b$c$d$e$f$g$h$i$j$k$l$m$n$o(B +;;2470 $(5$p$q$r$s$t$u$v$w$x$y$z${$|$}$~(B +;; +;;2120 $(6!!!"!#!$!%!&!'!(!)!*!+!,!-!.!/(B +;;2130 $(6!0!1!2!3!4!5!6!7!8!9!:!;!<!=!>!?(B +;;2140 $(6!@!A!B!C!D!E!F!G!H!I!J!K!L!M!N!O(B +;;2150 $(6!P!Q!R!S!T!U!V!W!X!Y!Z![!\!]!^!_(B +;;2160 $(6!`!a!b!c!d!e!f!g!h!i!j!k!l!m!n!o(B +;;2170 $(6!p!q!r!s!t!u!v!w!x!y!z!{!|!}!~(B +;; +;;2220 $(6"!"""#"$"%"&"'"(")"*"+","-"."/(B +;;2230 $(6"0"1"2"3"4"5"6"7"8"9":";"<"=">"?(B +;;2240 $(6"@"A"B"C"D"E"F"G"H"I"J"K"L"M"N"O(B +;;2250 $(6"P"Q"R"S"T"U"V"W"X"Y"Z"["\"]"^"_(B +;;2260 $(6"`"a"b"c"d"e"f"g"h"i"j"k"l"m"n"o(B +;;2270 $(6"p"q"r"s"t"u"v"w"x"y"z"{"|"}"~(B +;;2320 $(6#!#"###$#%#&#'#(#)#*#+#,#-#.#/(B +;;2330 $(6#0#1#2#3#4#5#6#7#8#9#:#;#<#=#>#?(B +;;2340 $(6#@#A#B#C#D#E#F#G#H#I#J#K#L#M#N#O(B +;;2350 $(6#P#Q#R#S#T#U#V#W#X#Y#Z#[#\#]#^#_(B +;;2360 $(6#`#a#b#c#d#e#f#g#h#i#j#k#l#m#n#o(B +;;2370 $(6#p#q#r#s#t#u#v#w#x#y#z#{#|#}#~(B +;; +;;2320 $(6$!$"$#$$$%$&$'$($)$*$+$,$-$.$/(B +;;2430 $(6$0$1$2$3$4$5$6$7$8$9$:$;$<$=$>$?(B +;;2440 $(6$@$A$B$C$D$E$F$G$H$I$J$K$L$M$N$O(B +;;2450 $(6$P$Q$R$S$T$U$V$W$X$Y$Z$[$\$]$^$_(B +;;2460 $(6$`$a$b$c$d$e$f$g$h$i$j$k$l$m$n$o(B +;;2470 $(6$p$q$r$s$t$u$v$w$x$y$z${$|$}$~(B +;; +;; +;; Modify the following table if you change the set of 1-column font. +;; +(defconst devanagari-1-column-char + '((?$(5!!(B . ?$(6!!(B) + (?$(5!"(B . ?$(6!"(B) + (?$(5!#(B . ?$(6!#(B) + (?$(5!$(B . nil) + (?$(5!%(B . nil) + (?$(5!&(B . ?$(6!&(B) + (?$(5!'(B . ?$(6!'(B) + (?$(5!((B . ?$(6!((B) + (?$(5!)(B . nil) + (?$(5!*(B . nil) + (?$(5!+(B . nil) + (?$(5!,(B . nil) + (?$(5!-(B . nil) + (?$(5!.(B . nil) + (?$(5!/(B . nil) + (?$(5!0(B . nil) + (?$(5!1(B . nil) + (?$(5!2(B . nil) + (?$(5!3(B . nil) + (?$(5!4(B . nil) + (?$(5!5(B . ?$(6!5(B) + (?$(5!6(B . nil) + (?$(5!7(B . nil) + (?$(5!8(B . nil) + (?$(5!9(B . nil) + (?$(5!:(B . nil) + (?$(5!;(B . nil) + (?$(5!<(B . nil) + (?$(5!=(B . ?$(6!=(B) + (?$(5!>(B . ?$(6!>(B) + (?$(5!?(B . ?$(6!?(B) + (?$(5!@(B . ?$(6!@(B) + (?$(5!A(B . nil) + (?$(5!B(B . ?$(6!B(B) + (?$(5!C(B . ?$(6!C(B) + (?$(5!D(B . ?$(6!D(B) + (?$(5!E(B . ?$(6!E(B) + (?$(5!F(B . ?$(6!F(B) + (?$(5!G(B . ?$(6!G(B) + (?$(5!H(B . ?$(6!H(B) + (?$(5!I(B . nil) + (?$(5!J(B . ?$(6!J(B) + (?$(5!K(B . ?$(6!K(B) + (?$(5!L(B . ?$(6!L(B) + (?$(5!M(B . ?$(6!M(B) + (?$(5!N(B . ?$(6!N(B) + (?$(5!O(B . ?$(6!O(B) + (?$(5!P(B . ?$(6!P(B) + (?$(5!Q(B . nil) + (?$(5!R(B . nil) + (?$(5!S(B . nil) + (?$(5!T(B . ?$(6!T(B) + (?$(5!U(B . nil) + (?$(5!V(B . ?$(6!V(B) + (?$(5!W(B . ?$(6!W(B) + (?$(5!X(B . ?$(6!X(B) + (?$(5!Y(B . nil) + (?$(5!Z(B . ?$(6!Z(B) + (?$(5 + (?$(5!^(B . ?$(6!^(B) + (?$(5!_(B . ?$(6!_(B) + (?$(5!`(B . ?$(6!`(B) + (?$(5!a(B . ?$(6!a(B) + (?$(5!b(B . ?$(6!b(B) + (?$(5!c(B . ?$(6!c(B) + (?$(5!d(B . ?$(6!d(B) + (?$(5!e(B . ?$(6!e(B) + (?$(5!f(B . ?$(6!f(B) + (?$(5!g(B . ?$(6!g(B) + (?$(5!h(B . ?$(6!h(B) + (?$(5!i(B . ?$(6!i(B) + (?$(5!j(B . ?$(6!j(B) + (nil . nil) + (nil . nil) + (nil . nil) + (nil . nil) + (nil . nil) + (nil . nil) + (?$(5!q(B . ?$(6!q(B) + (?$(5!r(B . ?$(6!r(B) + (?$(5!s(B . ?$(6!s(B) + (?$(5!t(B . ?$(6!t(B) + (?$(5!u(B . ?$(6!u(B) + (?$(5!v(B . ?$(6!v(B) + (?$(5!w(B . ?$(6!w(B) + (?$(5!x(B . ?$(6!x(B) + (?$(5!y(B . ?$(6!y(B) + (?$(5!z(B . ?$(6!z(B) + (nil . nil) + (nil . nil) + (nil . nil) + (nil . nil) + (?$(5"!(B . nil) + (?$(5""(B . nil) + (?$(5"#(B . nil) + (?$(5"$(B . nil) + (?$(5"%(B . ?$(6"%(B) + (?$(5"&(B . ?$(6"&(B) + (?$(5"'(B . nil) + (?$(5"((B . nil) + (?$(5")(B . nil) + (?$(5"*(B . nil) + (?$(5"+(B . nil) + (?$(5",(B . ?$(6",(B) + (?$(5"-(B . nil) + (?$(5".(B . ?$(6".(B) + (?$(5"/(B . nil) + (?$(5"0(B . nil) + (?$(5"1(B . nil) + (?$(5"2(B . nil) + (?$(5"3(B . ?$(6"3(B) + (?$(5"4(B . ?$(6"4(B) + (?$(5"5(B . ?$(6"5(B) + (?$(5"6(B . ?$(6"6(B) + (?$(5"7(B . nil) + (?$(5"8(B . ?$(6"8(B) + (?$(5"9(B . nil) + (?$(5":(B . ?$(6":(B) + (?$(5";(B . ?$(6";(B) + (?$(5"<(B . ?$(6"<(B) + (?$(5"=(B . nil) + (?$(5">(B . nil) + (?$(5"?(B . nil) + (?$(5"@(B . nil) + (?$(5"A(B . ?$(6"A(B) + (?$(5"B(B . ?$(6"B(B) + (?$(5"C(B . ?$(6"C(B) + (?$(5"D(B . nil) + (?$(5"E(B . ?$(6"E(B) + (?$(5"F(B . ?$(6"F(B) + (?$(5"G(B . ?$(6"G(B) + (?$(5"H(B . ?$(6"H(B) + (?$(5"I(B . ?$(6"I(B) + (?$(5"J(B . ?$(6"J(B) + (?$(5"K(B . ?$(6"K(B) + (?$(5"L(B . ?$(6"L(B) + (?$(5"M(B . ?$(6"M(B) + (?$(5"N(B . ?$(6"N(B) + (?$(5"O(B . nil) + (?$(5"P(B . nil) + (?$(5"Q(B . ?$(6"Q(B) + (?$(5"R(B . nil) + (?$(5"S(B . nil) + (?$(5"T(B . ?$(6"T(B) + (?$(5"U(B . ?$(6"U(B) + (?$(5"V(B . ?$(6"V(B) + (?$(5"W(B . ?$(6"W(B) + (?$(5"X(B . nil) + (?$(5"Y(B . nil) + (?$(5"Z(B . nil) + (?$(5"[(B . nil) + (?$(5"\(B . nil) + (?$(5"](B . nil) + (?$(5"^(B . nil) + (?$(5"_(B . nil) + (?$(5"`(B . ?$(6"`(B) + (?$(5"a(B . ?$(6"a(B) + (?$(5"b(B . ?$(6"b(B) + (?$(5"c(B . ?$(6"c(B) + (?$(5"d(B . ?$(6"d(B) + (?$(5"e(B . ?$(6"e(B) + (?$(5"f(B . ?$(6"f(B) + (?$(5"g(B . ?$(6"g(B) + (?$(5"h(B . ?$(6"h(B) + (?$(5"i(B . ?$(6"i(B) + (?$(5"j(B . ?$(6"j(B) + (?$(5"k(B . nil) + (?$(5"l(B . ?$(6"l(B) + (?$(5"m(B . ?$(6"m(B) + (?$(5"n(B . nil) + (?$(5"o(B . nil) + (?$(5"p(B . ?$(6"p(B) + (?$(5"q(B . ?$(6"q(B) + (?$(5"r(B . ?$(6"r(B) + (?$(5"s(B . ?$(6"s(B) + (?$(5"t(B . ?$(6"t(B) + (?$(5"u(B . ?$(6"u(B) + (?$(5"v(B . nil) + (?$(5"w(B . nil) + (?$(5"x(B . nil) + (?$(5"y(B . ?$(6"y(B) + (?$(5"z(B . ?$(6"z(B) + (?$(5"{(B . nil) + (?$(5"|(B . nil) + (?$(5"}(B . nil) + (?$(5"~(B . nil) + (?$(5#!(B . nil) + (?$(5#"(B . nil) + (?$(5##(B . nil) + (?$(5#$(B . nil) + (?$(5#%(B . nil) + (?$(5#&(B . ?$(6#&(B) + (?$(5#'(B . ?$(6#'(B) + (?$(5#((B . nil) + (?$(5#)(B . nil) + (?$(5#*(B . ?$(6#*(B) + (?$(5#+(B . nil) + (?$(5#,(B . nil) + (?$(5#-(B . nil) + (?$(5#.(B . nil) + (?$(5#/(B . nil) + (?$(5#0(B . nil) + (?$(5#1(B . nil) + (?$(5#2(B . nil) + (?$(5#3(B . nil) + (?$(5#4(B . nil) + (?$(5#5(B . ?$(6#5(B) + (?$(5#6(B . nil) + (?$(5#7(B . nil) + (?$(5#8(B . nil) + (?$(5#9(B . nil) + (?$(5#:(B . nil) + (?$(5#;(B . nil) + (?$(5#<(B . nil) + (?$(5#=(B . nil) + (?$(5#>(B . nil) + (?$(5#?(B . ?$(6#?(B) + (?$(5#@(B . ?$(6#@(B) + (?$(5#A(B . nil) + (?$(5#B(B . nil) + (?$(5#C(B . nil) + (?$(5#D(B . nil) + (?$(5#E(B . nil) + (?$(5#F(B . nil) + (?$(5#G(B . nil) + (?$(5#H(B . nil) + (?$(5#I(B . nil) + (?$(5#J(B . ?$(6#J(B) + (?$(5#K(B . nil) + (?$(5#L(B . nil) + (?$(5#M(B . nil) + (?$(5#N(B . nil) + (?$(5#O(B . nil) + (?$(5#P(B . nil) + (?$(5#Q(B . nil) + (?$(5#R(B . ?$(6#R(B) + (?$(5#S(B . nil) + (?$(5#T(B . nil) + (?$(5#U(B . nil) + (?$(5#V(B . nil) + (?$(5#W(B . nil) + (?$(5#X(B . nil) + (?$(5#Y(B . nil) + (?$(5#Z(B . nil) + (?$(5#[(B . nil) + (?$(5#\(B . nil) + (?$(5#](B . nil) + (?$(5#^(B . nil) + (?$(5#_(B . nil) + (?$(5#`(B . nil) + (?$(5#a(B . ?$(6#a(B) + (?$(5#b(B . ?$(6#b(B) + (?$(5#c(B . nil) + (?$(5#d(B . nil) + (?$(5#e(B . nil) + (?$(5#f(B . nil) + (?$(5#g(B . nil) + (?$(5#h(B . nil) + (?$(5#i(B . nil) + (?$(5#j(B . ?$(6#j(B) + (?$(5#k(B . ?$(6#k(B) + (?$(5#l(B . ?$(6#l(B) + (?$(5#m(B . nil) + (?$(5#n(B . nil) + (?$(5#o(B . nil) + (?$(5#p(B . nil) + (?$(5#q(B . nil) + (?$(5#r(B . nil) + (?$(5#s(B . nil) + (?$(5#t(B . nil) + (?$(5#u(B . nil) + (?$(5#v(B . nil) + (?$(5#w(B . nil) + (?$(5#x(B . nil) + (?$(5#y(B . nil) + (?$(5#z(B . nil) + (?$(5#{(B . nil) + (?$(5#|(B . nil) + (?$(5#}(B . nil) + (?$(5#~(B . nil) + (?$(5$!(B . nil) + (?$(5$"(B . nil) + (?$(5$#(B . nil) + (?$(5$$(B . nil) + (?$(5$%(B . nil) + (?$(5$&(B . nil) + (?$(5$'(B . nil) + (?$(5$((B . nil) + (?$(5$)(B . nil) + (?$(5$*(B . nil) + (?$(5$+(B . nil) + (?$(5$,(B . nil) + (?$(5$-(B . nil) + (?$(5$.(B . nil) + (?$(5$/(B . nil) + (?$(5$0(B . nil) + (?$(5$1(B . nil) + (?$(5$2(B . nil) + (?$(5$3(B . nil) + (?$(5$4(B . nil) + (?$(5$5(B . nil) + (?$(5$6(B . nil) + (?$(5$7(B . nil) + (?$(5$8(B . nil) + (?$(5$9(B . nil) + (?$(5$:(B . nil) + (?$(5$;(B . nil) + (?$(5$<(B . nil) + (?$(5$=(B . nil) + (?$(5$>(B . nil) + (?$(5$?(B . nil) + (?$(5$@(B . nil) + (?$(5$A(B . ?$(6$A(B) + (?$(5$B(B . nil) + (?$(5$C(B . nil) + (?$(5$D(B . nil) + (?$(5$E(B . ?$(6$E(B) + (?$(5$F(B . nil) + (?$(5$G(B . nil) + (?$(5$H(B . ?$(6$H(B) + (?$(5$I(B . ?$(6$I(B) + (?$(5$J(B . ?$(6$J(B) + (?$(5$K(B . nil) + (?$(5$L(B . nil) + (?$(5$M(B . nil) + (?$(5$N(B . ?$(6$N(B) + (?$(5$O(B . nil) + (?$(5$P(B . ?$(6$P(B) + (?$(5$Q(B . ?$(6$Q(B) + (?$(5$R(B . ?$(6$R(B) + (?$(5$S(B . nil) + (?$(5$T(B . nil) + (?$(5$U(B . nil) + (?$(5$V(B . nil) + (?$(5$W(B . nil) + (?$(5$X(B . nil) + (?$(5$Y(B . nil) + (?$(5$Z(B . nil) + (?$(5$[(B . nil) + (?$(5$\(B . nil) + (?$(5$](B . nil) + (?$(5$^(B . nil) + (?$(5$_(B . nil) + (?$(5$`(B . nil) + (?$(5$a(B . nil) + (?$(5$b(B . nil) + (?$(5$c(B . nil) + (?$(5$d(B . nil) + (?$(5$e(B . nil) + (?$(5$f(B . nil) + (?$(5$g(B . nil) + (?$(5$h(B . ?$(6$h(B) + (?$(5$i(B . ?$(6$i(B) + (?$(5$j(B . ?$(6$j(B) + (?$(5$k(B . nil) + (?$(5$l(B . ?$(6$l(B) + (?$(5$m(B . ?$(6$m(B) + (?$(5$n(B . ?$(6$n(B) + (?$(5$o(B . nil) + (?$(5$p(B . ?$(6$p(B) + (?$(5$q(B . ?$(6$q(B) + (?$(5$r(B . ?$(6$r(B) + (?$(5$s(B . nil) + (?$(5$t(B . nil) + (?$(5$u(B . ?$(6$u(B) + (?$(5$v(B . ?$(6$v(B) + (?$(5$w(B . nil) + (?$(5$x(B . ?$(6$x(B) + (?$(5$y(B . ?$(6$y(B) + (?$(5$z(B . nil) + (?$(5${(B . nil) + (?$(5$|(B . nil) + (?$(5$}(B . nil) + (?$(5$~(B . nil) + )) + +;;; devanagari.el ends here diff --git a/lisp/language/ethio-util.el b/lisp/language/ethio-util.el new file mode 100644 index 00000000000..7fa0a4d7c04 --- /dev/null +++ b/lisp/language/ethio-util.el @@ -0,0 +1,1068 @@ +;; 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 ("$(2$Q(B") nil ("$(2$P(B") nil +;;; 0 1 2 3 4 5 6 7 8 9 : ; < = > ? @ + nil nil nil nil nil nil nil nil nil nil ("$(2$S(B") ("$(2$R(B") nil nil nil nil nil +;;; A + ("$(2"V(B" (?2 "$(2#b(B")) +;;; B + ("$(2!F(B" (?e "$(2!A(B") (?u "$(2!B(B") (?i "$(2!C(B") (?a "$(2!D(B") (?E "$(2!E(B") (?o "$(2!G(B") (?| "$(2!F(B") + (?W "$(2!H(B" (?a "$(2!H(B") + (?e "$(2!F#L(B") (?u "$(2!F#M(B") (?i "$(2!F#N(B") (?E "$(2!F#P(B") (?' "$(2!F#M(B"))) +;;; C + ("$(2"8(B" (?e "$(2"3(B") (?u "$(2"4(B") (?i "$(2"5(B") (?a "$(2"6(B") (?E "$(2"7(B") (?o "$(2"9(B") (?| "$(2"8(B") + (?W "$(2":(B" (?a "$(2":(B") + (?e "$(2"8#L(B") (?u "$(2"8#M(B") (?i "$(2"8#N(B") (?E "$(2"8#P(B") (?' "$(2"8#M(B"))) +;;; D + ("$(2$0(B" (?e "$(2$+(B") (?u "$(2$,(B") (?i "$(2$-(B") (?a "$(2$.(B") (?E "$(2$/(B") (?o "$(2$1(B") (?| "$(2$0(B")) +;;; E + ("$(2"W(B" (?2 "$(2#c(B")) +;;; F + ("$(2"@(B" (?e "$(2";(B") (?u "$(2"<(B") (?i "$(2"=(B") (?a "$(2">(B") (?E "$(2"?(B") (?o "$(2"A(B") (?| "$(2"@(B") + (?W "$(2"B(B" (?a "$(2"B(B") + (?e "$(2"@#L(B") (?u "$(2"@#M(B") (?i "$(2"@#N(B") (?E "$(2"@#P(B") (?' "$(2"@#M(B"))) +;;; G + ("$(2$>(B" (?e "$(2$9(B") (?u "$(2$:(B") (?i "$(2$;(B") (?a "$(2$<(B") (?E "$(2$=(B") (?o "$(2$?(B") (?| "$(2$>(B")) +;;; H + ("$(2$"(B" (?e "$(2#{(B") (?u "$(2#|(B") (?i "$(2#}(B") (?a "$(2#~(B") (?E "$(2$!(B") (?o "$(2$#(B") (?| "$(2$"(B")) +;;; I + ("$(2"X(B" (?2 "$(2#d(B")) +;;; J + ("$(2$7(B" (?e "$(2$2(B") (?u "$(2$3(B") (?i "$(2$4(B") (?a "$(2$5(B") (?E "$(2$6(B") (?o "$(2$8(B") (?| "$(2$7(B")) +;;; K + ("$(2"x(B" (?e "$(2"s(B") (?u "$(2"t(B") (?i "$(2"u(B") (?a "$(2"v(B") (?E "$(2"w(B") (?o "$(2"y(B") (?| "$(2"x(B") + (?W "$(2"{(B" (?e "$(2"z(B") (?u "$(2"{(B") (?i "$(2"|(B") (?a "$(2"}(B") (?E "$(2"~(B"))) +;;; L + ("$(2!&(B" (?e "$(2!!(B") (?u "$(2!"(B") (?i "$(2!#(B") (?a "$(2!$(B") (?E "$(2!%(B") (?o "$(2!'(B") (?| "$(2!&(B") + (?W "$(2!((B" (?a "$(2!((B") + (?e "$(2!&#L(B") (?u "$(2!&#M(B") (?i "$(2!&#N(B") (?E "$(2!&#P(B") (?' "$(2!&#M(B"))) +;;; M + ("$(2!.(B" (?e "$(2!)(B") (?u "$(2!*(B") (?i "$(2!+(B") (?a "$(2!,(B") (?E "$(2!-(B") (?o "$(2!/(B") (?| "$(2!.(B") + (?W "$(2!0(B" (?a "$(2!0(B") + (?e "$(2!.#L(B") (?u "$(2!.#M(B") (?i "$(2!.#N(B") (?E "$(2!.#P(B") (?' "$(2!.#M(B"))) +;;; N + ("$(2!n(B" (?e "$(2!i(B") (?u "$(2!j(B") (?i "$(2!k(B") (?a "$(2!l(B") (?E "$(2!m(B") (?o "$(2!o(B") (?| "$(2!n(B") + (?W "$(2!p(B" (?a "$(2!p(B") + (?e "$(2!n#L(B") (?u "$(2!n#M(B") (?i "$(2!n#N(B") (?E "$(2!n#P(B") (?' "$(2!n#M(B"))) +;;; O + ("$(2"Y(B" (?2 "$(2#e(B")) +;;; P + ("$(2$E(B" (?e "$(2$@(B") (?u "$(2$A(B") (?i "$(2$B(B") (?a "$(2$C(B") (?E "$(2$D(B") (?o "$(2$F(B") (?| "$(2$E(B")) +;;; Q + ("$(2#2(B" (?e "$(2#-(B") (?u "$(2#.(B") (?i "$(2#/(B") (?a "$(2#0(B") (?E "$(2#1(B") (?o "$(2#3(B") (?| "$(2#2(B") + (?W "$(2#5(B" (?e "$(2#4(B") (?u "$(2#5(B") (?i "$(2#6(B") (?a "$(2#7(B") (?E "$(2#8(B"))) +;;; R + ("$(2!6(B" (?e "$(2!1(B") (?u "$(2!2(B") (?i "$(2!3(B") (?a "$(2!4(B") (?E "$(2!5(B") (?o "$(2!7(B") (?| "$(2!6(B") + (?W "$(2!8(B" (?a "$(2!8(B") + (?e "$(2!6#L(B") (?u "$(2!6#M(B") (?i "$(2!6#N(B") (?E "$(2!6#P(B") (?' "$(2!6#M(B"))) +;;; S + ("$(2"P(B" (?e "$(2"K(B") (?u "$(2"L(B") (?i "$(2"M(B") (?a "$(2"N(B") (?E "$(2"O(B") (?o "$(2"Q(B") (?| "$(2"P(B") + (?W "$(2"R(B" (?a "$(2"R(B") + (?e "$(2"P#L(B") (?u "$(2"P#M(B") (?i "$(2"P#N(B") (?E "$(2"P#P(B") (?' "$(2"P#M(B")) + (?2 "$(2#](B" (?| "$(2#](B") + (?e "$(2#X(B") (?u "$(2#Y(B") (?i "$(2#Z(B") (?a "$(2#[(B") (?E "$(2#\(B") (?o "$(2#^(B") + (?W "$(2"R(B" + (?a "$(2"R(B") + (?e "$(2#]#L(B") (?u "$(2#]#M(B") (?i "$(2#]#N(B") (?E "$(2#]#P(B") (?' "$(2#]#M(B")))) + +;;; T + ("$(2"0(B" (?e "$(2"+(B") (?u "$(2",(B") (?i "$(2"-(B") (?a "$(2".(B") (?E "$(2"/(B") (?o "$(2"1(B") (?| "$(2"0(B") + (?W "$(2"2(B" (?a "$(2"2(B") + (?e "$(2"0#L(B") (?u "$(2"0#M(B") (?i "$(2"0#N(B") (?E "$(2"0#P(B") (?' "$(2"0#M(B"))) +;;; U + ("$(2"T(B" (?2 "$(2#`(B")) +;;; V + ("$(2!N(B" (?e "$(2!I(B") (?u "$(2!J(B") (?i "$(2!K(B") (?a "$(2!L(B") (?E "$(2!M(B") (?o "$(2!O(B") (?| "$(2!N(B") + (?W "$(2!P(B" (?a "$(2!P(B") + (?e "$(2!N#L(B") (?u "$(2!N#M(B") (?i "$(2!N#N(B") (?E "$(2!N#P(B") (?' "$(2!N#M(B"))) +;;; W + ("$(2#M(B" (?e "$(2#L(B") (?u "$(2#M(B") (?i "$(2#N(B") (?a "$(2#O(B") (?E "$(2#P(B")) +;;; X + ("$(2#y(B" (?e "$(2#t(B") (?u "$(2#u(B") (?i "$(2#v(B") (?a "$(2#w(B") (?E "$(2#x(B") (?o "$(2#z(B") (?| "$(2#y(B")) +;;; Y + ("$(2$)(B" (?e "$(2$$(B") (?u "$(2$%(B") (?i "$(2$&(B") (?a "$(2$'(B") (?E "$(2$((B") (?o "$(2$*(B") (?| "$(2$)(B")) +;;; Z + ("$(2!~(B" (?e "$(2!y(B") (?u "$(2!z(B") (?i "$(2!{(B") (?a "$(2!|(B") (?E "$(2!}(B") (?o "$(2"!(B") (?| "$(2!~(B") + (?W "$(2""(B" (?a "$(2""(B") + (?e "$(2!~#L(B") (?u "$(2!~#M(B") (?i "$(2!~#N(B") (?E "$(2!~#P(B") (?' "$(2!~#M(B"))) +;;; [ \ ] ^ _ + nil nil nil nil nil +;;; ` + ("`" + (?e "$(2#_(B") (?u "$(2#`(B") (?U "$(2#`(B") (?i "$(2#a(B") (?a "$(2#b(B") (?A "$(2#b(B") + (?E "$(2#c(B") (?I "$(2#d(B") (?o "$(2#e(B") (?O "$(2#e(B") + (?s "$(2#V(B" + (?e "$(2#Q(B") (?u "$(2#R(B") (?i "$(2#S(B") (?a "$(2#T(B") (?E "$(2#U(B") (?o "$(2#W(B") (?| "$(2#V(B") + (?W "$(2"J(B" (?a "$(2"J(B") + (?e "$(2#V#L(B") (?u "$(2#V#M(B") (?i "$(2#V#N(B") (?E "$(2#V#P(B") (?' "$(2#V#M(B"))) + (?S "$(2#](B" + (?e "$(2#X(B") (?u "$(2#Y(B") (?i "$(2#Z(B") (?a "$(2#[(B") (?E "$(2#\(B") (?o "$(2#^(B") (?| "$(2#](B") + (?W "$(2"R(B" (?a "$(2"R(B") + (?e "$(2#]#L(B") (?u "$(2#]#M(B") (?i "$(2#]#N(B") (?E "$(2#]#P(B") (?' "$(2#]#M(B"))) + (?h "$(2#k(B" + (?e "$(2#f(B") (?u "$(2#g(B") (?i "$(2#h(B") (?a "$(2#i(B") (?E "$(2#j(B") (?o "$(2#l(B") (?| "$(2#k(B") + (?W "$(2"c(B" (?e "$(2"b(B") (?u "$(2"c(B") (?i "$(2"d(B") (?a "$(2"e(B") (?E "$(2"f(B"))) + (?k "$(2#r(B" + (?e "$(2#m(B") (?u "$(2#n(B") (?i "$(2#o(B") (?a "$(2#p(B") (?E "$(2#q(B") (?o "$(2#s(B") (?| "$(2#r(B"))) +;;; a + ("$(2"S(B" (?2 "$(2#b(B")) + +;;; b + ("$(2!F(B" (?e "$(2!A(B") (?u "$(2!B(B") (?i "$(2!C(B") (?a "$(2!D(B") (?E "$(2!E(B") (?o "$(2!G(B") (?| "$(2!F(B") + (?W "$(2!H(B" (?a "$(2!H(B") + (?e "$(2!F#L(B") (?u "$(2!F#M(B") (?i "$(2!F#N(B") (?E "$(2!F#P(B") (?' "$(2!F#M(B"))) +;;; c + ("$(2!^(B" (?e "$(2!Y(B") (?u "$(2!Z(B") (?i "$(2![(B") (?a "$(2!\(B") (?E "$(2!](B") (?o "$(2!_(B") (?| "$(2!^(B") + (?W "$(2!`(B" (?a "$(2!`(B") + (?e "$(2!^#L(B") (?u "$(2!^#M(B") (?i "$(2!^#N(B") (?E "$(2!^#P(B") (?' "$(2!^#M(B"))) +;;; d + ("$(2"((B" (?e "$(2"#(B") (?u "$(2"$(B") (?i "$(2"%(B") (?a "$(2"&(B") (?E "$(2"'(B") (?o "$(2")(B") (?| "$(2"((B") + (?W "$(2"*(B" (?a "$(2"*(B") + (?e "$(2"(#L(B") (?u "$(2"(#M(B") (?i "$(2"(#N(B") (?E "$(2"(#P(B") (?' "$(2"(#M(B"))) +;;; e + ("$(2"S(B" (?2 "$(2#_(B") (?3 "$(2"Z(B")) +;;; f + ("$(2"@(B" (?e "$(2";(B") (?u "$(2"<(B") (?i "$(2"=(B") (?a "$(2">(B") (?E "$(2"?(B") (?o "$(2"A(B") (?| "$(2"@(B") + (?W "$(2"B(B" (?a "$(2"B(B") + (?e "$(2"@#L(B") (?u "$(2"@#M(B") (?i "$(2"@#N(B") (?E "$(2"@#P(B") (?' "$(2"@#M(B"))) +;;; g + ("$(2#>(B" (?e "$(2#9(B") (?u "$(2#:(B") (?i "$(2#;(B") (?a "$(2#<(B") (?E "$(2#=(B") (?o "$(2#?(B") (?| "$(2#>(B") + (?W "$(2#A(B" (?e "$(2#@(B") (?u "$(2#A(B") (?i "$(2#B(B") (?a "$(2#C(B") (?E "$(2#D(B"))) +;;; h + ("$(2"`(B" (?e "$(2"[(B") (?u "$(2"\(B") (?i "$(2"](B") (?a "$(2"^(B") (?E "$(2"_(B") (?o "$(2"a(B") (?| "$(2"`(B") + (?W "$(2"c(B" (?e "$(2"b(B") (?u "$(2"c(B") (?i "$(2"d(B") (?a "$(2"e(B") (?E "$(2"f(B")) + (?2 "$(2#k(B" (?e "$(2#f(B") (?u "$(2#g(B") (?i "$(2#h(B") (?a "$(2#i(B") (?E "$(2#j(B") (?o "$(2#l(B") + (?| "$(2#k(B") + (?W "$(2"c(B" (?e "$(2"b(B") (?u "$(2"c(B") (?i "$(2"d(B") (?a "$(2"e(B") (?E "$(2"f(B")))) +;;; i + ("$(2"U(B" (?2 "$(2#a(B")) +;;; j + ("$(2$7(B" (?e "$(2$2(B") (?u "$(2$3(B") (?i "$(2$4(B") (?a "$(2$5(B") (?E "$(2$6(B") (?o "$(2$8(B") (?| "$(2$7(B")) +;;; k + ("$(2"l(B" (?e "$(2"g(B") (?u "$(2"h(B") (?i "$(2"i(B") (?a "$(2"j(B") (?E "$(2"k(B") (?o "$(2"m(B") (?| "$(2"l(B") + (?W "$(2"o(B" (?e "$(2"n(B") (?u "$(2"o(B") (?i "$(2"p(B") (?a "$(2"q(B") (?E "$(2"r(B")) + (?2 "$(2#r(B" (?e "$(2#m(B") (?u "$(2#n(B") (?i "$(2#o(B") (?a "$(2#p(B") (?E "$(2#q(B") (?o "$(2#s(B") + (?| "$(2#r(B"))) +;;; l + ("$(2!&(B" (?e "$(2!!(B") (?u "$(2!"(B") (?i "$(2!#(B") (?a "$(2!$(B") (?E "$(2!%(B") (?o "$(2!'(B") (?| "$(2!&(B") + (?W "$(2!((B" (?a "$(2!((B") + (?e "$(2!&#L(B") (?u "$(2!&#M(B") (?i "$(2!&#N(B") (?E "$(2!&#P(B") (?' "$(2!&#M(B"))) +;;; m + ("$(2!.(B" (?e "$(2!)(B") (?u "$(2!*(B") (?i "$(2!+(B") (?a "$(2!,(B") (?E "$(2!-(B") (?o "$(2!/(B") (?| "$(2!.(B") + (?W "$(2!0(B" (?a "$(2!0(B") + (?e "$(2!.#L(B") (?u "$(2!.#M(B") (?i "$(2!.#N(B") (?E "$(2!.#P(B") (?' "$(2!.#M(B"))) +;;; n + ("$(2!f(B" (?e "$(2!a(B") (?u "$(2!b(B") (?i "$(2!c(B") (?a "$(2!d(B") (?E "$(2!e(B") (?o "$(2!g(B") (?| "$(2!f(B") + (?W "$(2!h(B" (?a "$(2!h(B") + (?e "$(2!f#L(B") (?u "$(2!f#M(B") (?i "$(2!f#N(B") (?E "$(2!f#P(B") (?' "$(2!f#M(B"))) +;;; o + ("$(2"Y(B" (?2 "$(2#e(B")) +;;; p + ("$(2$L(B" (?e "$(2$G(B") (?u "$(2$H(B") (?i "$(2$I(B") (?a "$(2$J(B") (?E "$(2$K(B") (?o "$(2$M(B") (?| "$(2$L(B")) +;;; q + ("$(2#&(B" (?e "$(2#!(B") (?u "$(2#"(B") (?i "$(2##(B") (?a "$(2#$(B") (?E "$(2#%(B") (?o "$(2#'(B") (?| "$(2#&(B") + (?W "$(2#)(B" (?e "$(2#((B") (?u "$(2#)(B") (?i "$(2#*(B") (?a "$(2#+(B") (?E "$(2#,(B"))) +;;; r + ("$(2!6(B" (?e "$(2!1(B") (?u "$(2!2(B") (?i "$(2!3(B") (?a "$(2!4(B") (?E "$(2!5(B") (?o "$(2!7(B") (?| "$(2!6(B") + (?W "$(2!8(B" (?a "$(2!8(B") + (?e "$(2!6#L(B") (?u "$(2!6#M(B") (?i "$(2!6#N(B") (?E "$(2!6#P(B") (?' "$(2!6#M(B"))) +;;; s + ("$(2"H(B" (?e "$(2"C(B") (?u "$(2"D(B") (?i "$(2"E(B") (?a "$(2"F(B") (?E "$(2"G(B") (?o "$(2"I(B") (?| "$(2"H(B") + (?W "$(2"J(B" (?a "$(2"J(B") + (?e "$(2"H#L(B") (?u "$(2"H#M(B") (?i "$(2"H#N(B") (?E "$(2"H#P(B") (?' "$(2"H#M(B")) + (?2 "$(2#V(B" (?e "$(2#Q(B") (?u "$(2#R(B") (?i "$(2#S(B") (?a "$(2#T(B") (?E "$(2#U(B") (?o "$(2#W(B") + (?| "$(2#V(B") + (?W "$(2"J(B" (?a "$(2"J(B") + (?e "$(2#V#L(B") (?u "$(2#V#M(B") (?i "$(2#V#N(B") (?E "$(2#V#P(B") + (?' "$(2#V#M(B")))) +;;; t + ("$(2!V(B" (?e "$(2!Q(B") (?u "$(2!R(B") (?i "$(2!S(B") (?a "$(2!T(B") (?E "$(2!U(B") (?o "$(2!W(B") (?| "$(2!V(B") + (?W "$(2!X(B" (?a "$(2!X(B") + (?e "$(2!V#L(B") (?u "$(2!V#M(B") (?i "$(2!V#N(B") (?E "$(2!V#P(B") (?' "$(2!V#M(B"))) +;;; u + ("$(2"T(B" (?2 "$(2#`(B")) +;;; v + ("$(2!N(B" (?e "$(2!I(B") (?u "$(2!J(B") (?i "$(2!K(B") (?a "$(2!L(B") (?E "$(2!M(B") (?o "$(2!O(B") (?| "$(2!N(B") + (?W "$(2!P(B" (?a "$(2!P(B") + (?e "$(2!N#L(B") (?u "$(2!N#M(B") (?i "$(2!N#N(B") (?E "$(2!N#P(B") (?' "$(2!N#M(B"))) +;;; w + ("$(2#J(B" (?e "$(2#E(B") (?u "$(2#F(B") (?i "$(2#G(B") (?a "$(2#H(B") (?E "$(2#I(B") (?o "$(2#K(B") (?| "$(2#J(B") + (?W "$(2#M(B" (?e "$(2#L(B") (?u "$(2#M(B") (?i "$(2#N(B") (?a "$(2#O(B") (?E "$(2#P(B"))) +;;; x + ("$(2!>(B" (?e "$(2!9(B") (?u "$(2!:(B") (?i "$(2!;(B") (?a "$(2!<(B") (?E "$(2!=(B") (?o "$(2!?(B") (?| "$(2!>(B") + (?W "$(2!@(B" (?a "$(2!@(B") + (?e "$(2!>#L(B") (?u "$(2!>#M(B") (?i "$(2!>#N(B") (?E "$(2!>#P(B") (?' "$(2!>#M(B"))) +;;; y + ("$(2$)(B" (?e "$(2$$(B") (?u "$(2$%(B") (?i "$(2$&(B") (?a "$(2$'(B") (?E "$(2$((B") (?o "$(2$*(B") (?| "$(2$)(B")) +;;; z + ("$(2!v(B" (?e "$(2!q(B") (?u "$(2!r(B") (?i "$(2!s(B") (?a "$(2!t(B") (?E "$(2!u(B") (?o "$(2!w(B") (?| "$(2!v(B") + (?W "$(2!x(B" (?a "$(2!x(B") + (?e "$(2!v#L(B") (?u "$(2!v#M(B") (?i "$(2!v#N(B") (?E "$(2!v#P(B") (?' "$(2!v#M(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 ?$(2$P(B)) + + ;; soft ascii mode, pre = \, fol = , + ((= fol ?,) + (delete-char 1) + (insert ?$(2$Q(B)) + + ;; soft ascii mode, pre = \, fol = ; + ((= fol ?\;) + (delete-char 1) + (insert ?$(2$R(B)) + + ;; soft ascii mode, pre = \, fol = : + ((= fol ?:) + (delete-char 1) + (insert ?$(2$S(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 ?$(2$O(B)) + ((= ch ?*) + (insert ?$(2$T(B)) + ((= ch ?<) + (insert ?$(2$U(B)) + ((= ch ?>) + (insert ?$(2$V(B)) + ((= ch ?~) + (setq ch (following-char)) + (delete-char 1) + (cond + ((= ch ?e) + (insert "$(2$k(B")) + ((= ch ?E) + (insert "$(2$l(B")) + ((= ch ?a) + (insert "$(2$m(B")) + ((= ch ?A) + (insert "$(2$n(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 [?$(2$`(B ?$(2$a(B ?$(2$b(B ?$(2$c(B ?$(2$d(B ?$(2$e(B ?$(2$f(B ?$(2$g(B ?$(2$h(B] (- ch ?1))) + (setq z (1- z))) + + ;; first digit is 2, 3, ..., or 9 + ((/= ch ?1) + (insert (aref [?$(2$X(B ?$(2$Y(B ?$(2$Z(B ?$(2$[(B ?$(2$\(B ?$(2$](B ?$(2$^(B ?$(2$_(B] (- ch ?2)))) + + ;; single 1 + ((= z 0) + (insert "$(2$W(B"))) + + ;; 100 + (if (= (mod z 4) 2) + (insert"$(2$i(B")) + + ;; 10000 + (insert-char ?$(2$j(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, $(2$`$_$i$g$](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 "[$(2$N$O(B]" nil t) + (replace-match " " nil nil))) + + ((= ch ?2) + + ;; An Ethiopic word separator is always converted to + ;; a double column space. + (while (search-forward "$(2$O(B" nil t) + (replace-match "$(2$N(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$(2$N(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 "[ $(2$N(B]\\([ $(2$N(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 "$(2$O(B\\1" nil nil))))))))) + +;; +;; special characters +;; + +;;;###autoload +(defun ethio-input-special-character (arg) + "Allow the user to input special characters." + (interactive "*cInput number: 1.$(2$k(B 2.$(2$l(B 3.$(2$m(B 4.$(2$n(B") + (cond + ((= arg ?1) + (insert ?$(2$k(B)) + ((= arg ?2) + (insert ?$(2$l(B)) + ((= arg ?3) + (insert ?$(2$m(B)) + ((= arg ?4) + (insert ?$(2$n(B)) + (t + (error "")))) + +;; +(provide 'language/ethio-util) + +;;; Local Variables: +;;; generated-autoload-file: "../loaddefs.el" +;;; End: +;;; ethio-util.el ends here diff --git a/lisp/language/ethiopic.el b/lisp/language/ethiopic.el new file mode 100644 index 00000000000..d08ca5b1a43 --- /dev/null +++ b/lisp/language/ethiopic.el @@ -0,0 +1,85 @@ +;;; 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 ($(2"S!,!6!l(B) $(2#Q!$!.(B, Tigrigna ($(2!V#>!6!l(B) $(2"C!$!,!V(B"))) + +;;; ethiopic.el ends here diff --git a/lisp/language/european.el b/lisp/language/european.el new file mode 100644 index 00000000000..e10169d24a7 --- /dev/null +++ b/lisp/language/european.el @@ -0,0 +1,105 @@ +;;; 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,A|_(B Gott, Ciao, ,A!(BHola!"))) + +;;; european.el ends here diff --git a/lisp/language/greek.el b/lisp/language/greek.el new file mode 100644 index 00000000000..114dc5b7fdc --- /dev/null +++ b/lisp/language/greek.el @@ -0,0 +1,59 @@ +;;; 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 (,FGkk]mija(B) ,FCei\(B ,Fsar(B"))) + +;;; greek.el ends here diff --git a/lisp/language/hebrew.el b/lisp/language/hebrew.el new file mode 100644 index 00000000000..bece50500e2 --- /dev/null +++ b/lisp/language/hebrew.el @@ -0,0 +1,60 @@ +;;; 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 ,Hylem(B"))) + +;;; hebew.el ends here diff --git a/lisp/language/indian.el b/lisp/language/indian.el new file mode 100644 index 00000000000..75ef6ffe55b --- /dev/null +++ b/lisp/language/indian.el @@ -0,0 +1,328 @@ +;;; 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 //(5!"#$%&'()*+,-./(B +;; 0xb0 (50123456789:;<=>?(B +;; 0xc0 (5@ABCDEFGHIJKLMNO(B +;; 0xd0 (5PQRSTUVWXYZ[\]^_(B +;; 0xe0 (5`abcdefghijklmno(B +;; 0xf0 (5pqrstuvwxyz{|}~(B// + +;; Note - In IS 13194, several symbols are obtained by special +;; combination of several characters and Nukta sign. +;; +;; Sanskrit Vowel R -> (5*(B + (5i(B +;; Sanskrit Vowel L -> (5&(B + (5i(B +;; Sanskrit Vowel LL -> (5'(B + (5i(B +;; Sanskrit Avagrah -> (5j(B + (5i(B +;; OM -> (5!(B + (5i(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 ?(5$(B)) +;; "$(5!$(B" + +(let ((deflist + '(;; chars syntax category + ("(5!"#(B" "w" ?7) ; vowel-modifying diacritical mark + ; chandrabindu, anuswar, visarga + ("(5$(B-(52(B" "w" ?5) ; independent vowel + ("(53(B-(5X(B" "w" ?0) ; consonant + ("(5Z(B-(5g(B" "w" ?8) ; matra + ("(5q(B-(5z(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" . "(53(B") + ("kh" . "(54(B") + ("g" . "(55(B") + ("gh" . "(56(B") + ("N^" . "(57(B") + ("ch" . "(58(B") + ("chh" . "(59(B") + ("j" . "(5:(B") + ("jh" . "(5;(B") + ("JN" . "(5<(B") + ("T" . "(5=(B") + ("Th" . "(5>(B") + ("D" . "(5?(B") + ("Dh" . "(5@(B") + ("N" . "(5A(B") + ("t" . "(5B(B") + ("th" . "(5C(B") + ("d" . "(5D(B") + ("dh" . "(5E(B") + ("n" . "(5F(B") + ("nh" . "(5G(B") ; For transcription of non-Devanagari Languages. + ("p" . "(5H(B") + ("ph" . "(5I(B") + ("b" . "(5J(B") + ("bh" . "(5K(B") + ("m" . "(5L(B") + ("y" . "(5M(B") + ("yh" . "(5N(B") ; For transcription of non-Devanagari Languages. + ("r" . "(5O(B") + ("rh" . "(5P(B") ; For transcription of non-Devanagari Languages. + ("l" . "(5Q(B") + ("v" . "(5T(B") + ("sh" . "(5U(B") + ("shh" . "(5V(B") + ("s" . "(5W(B") + ("h" . "(5X(B") + ("ld" . "(5R(B") + ("L" . "(5R(B") + ("ksh" . "$(5!3!h!V(B") + ("GY" . "***GY***") ; Must check out later. + ;; special consonants + ("q" . "(53i(B") + ("K" . "(54i(B") + ("G" . "(55i(B") + ("z" . "(5:i(B") + ("f" . "(5Ii(B") + (".D" . "(5?i(B") + (".Dh" . "(5@i(B") + )) + +(defvar indian-itrans-vowel-sign-alist + '( + ;; Special treatment unique to IS 13194 Transliteration + ("" . "(5h(B") + ("a" . "") + ;; Matra (Vowel Sign) + ("aa" . "(5Z(B") + ("A" . "(5Z(B") + ("i" . "(5[(B") + ("ii" . "(5\(B") + ("I" . "(5\(B") + ("u" . "(5](B") + ("uu" . "(5^(B") + ("U" . "(5^(B") + ("R^i" . "(5_(B") ; These must be checked out later. + ("R^I" . "(5_i(B") + ("L^i" . "(5[i(B") + ("L^I" . "(5\i(B") + ("E" . "(5`(B") ; For transcription of non-Devanangri Languages. + ("e" . "(5a(B") + ("ai" . "(5b(B") + ;; ("e.c" . "(5c(B") ; Tentatively suppressed. + ("O" . "(5d(B") ; For transcription of non-Devanagari Languages. + ("o" . "(5e(B") + ("au" . "(5f(B") + ;; ("o.c" . "(5g(B") ; Tentatively suppressed. + )) + +;; +;; Independent vowels and other signs. +;; + +(defvar indian-itrans-other-letters-alist + '( + ("a" . "(5$(B") + ("aa" . "(5%(B") + ("A" . "(5%(B") + ("i" . "(5&(B") + ("ii" . "(5'(B") + ("I" . "(5'(B") + ("u" . "(5((B") + ("uu" . "(5)(B") + ("U" . "(5)(B") + ("R^i" . "(5*(B") + ("R^I" . "(5*i(B") + ("L^i" . "(5&i(B") + ("L^I" . "(5'i(B") + ("E" . "(5+(B") ; For transcription of non-Devanagari Languages. + ("e" . "(5,(B") + ("ai" . "(5-(B") + ;; ("e.c" . "(5.(B") ; Candra E + ("O" . "(5/(B") ; For transcription of non-Devanagari Languages. + ("o" . "(50(B") + ("au" . "(51(B") + ;; ("o.c" . "(52(B") ; Candra O + ("M" . "(5$(B") + ("H" . "(5#(B") + ("AUM" . "(5!i(B") + ("OM" . "(5!i(B") + (".r" . "(5Oh(B") + (".n" . "(5"(B") + (".N" . "(5!(B") + (".h" . "(5h(B") ; Halant + (".." . "(5j(B") + (".a" . "(5ji(B") ; Avagrah + ("0" . "(5q(B") + ("1" . "(5r(B") + ("2" . "(5s(B") + ("3" . "(5t(B") + ("4" . "(5u(B") + ("5" . "(5v(B") + ("6" . "(5w(B") + ("7" . "(5x(B") + ("8" . "(5y(B") + ("9" . "(5z(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 "[(5$(B-(52(B]") + (consonant "[(53(B-(5X(B]") + (vowel-sign "[(5Z(B-(5g(B]") + (misc "[(5q(B-(5z(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 "\\((5h(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 diff --git a/lisp/language/japan-util.el b/lisp/language/japan-util.el new file mode 100644 index 00000000000..2dab876fd51 --- /dev/null +++ b/lisp/language/japan-util.el @@ -0,0 +1,272 @@ +;; 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 + '((?$B$"(B ?$B%"(B ?(I1(B) (?$B$$(B ?$B%$(B ?(I2(B) (?$B$&(B ?$B%&(B ?(I3(B) (?$B$((B ?$B%((B ?(I4(B) (?$B$*(B ?$B%*(B ?(I5(B) + (?$B$+(B ?$B%+(B ?(I6(B) (?$B$-(B ?$B%-(B ?(I7(B) (?$B$/(B ?$B%/(B ?(I8(B) (?$B$1(B ?$B%1(B ?(I9(B) (?$B$3(B ?$B%3(B ?(I:(B) + (?$B$5(B ?$B%5(B ?(I;(B) (?$B$7(B ?$B%7(B ?(I<(B) (?$B$9(B ?$B%9(B ?(I=(B) (?$B$;(B ?$B%;(B ?(I>(B) (?$B$=(B ?$B%=(B ?(I?(B) + (?$B$?(B ?$B%?(B ?(I@(B) (?$B$A(B ?$B%A(B ?(IA(B) (?$B$D(B ?$B%D(B ?(IB(B) (?$B$F(B ?$B%F(B ?(IC(B) (?$B$H(B ?$B%H(B ?(ID(B) + (?$B$J(B ?$B%J(B ?(IE(B) (?$B$K(B ?$B%K(B ?(IF(B) (?$B$L(B ?$B%L(B ?(IG(B) (?$B$M(B ?$B%M(B ?(IH(B) (?$B$N(B ?$B%N(B ?(II(B) + (?$B$O(B ?$B%O(B ?(IJ(B) (?$B$R(B ?$B%R(B ?(IK(B) (?$B$U(B ?$B%U(B ?(IL(B) (?$B$X(B ?$B%X(B ?(IM(B) (?$B$[(B ?$B%[(B ?(IN(B) + (?$B$^(B ?$B%^(B ?(IO(B) (?$B$_(B ?$B%_(B ?(IP(B) (?$B$`(B ?$B%`(B ?(IQ(B) (?$B$a(B ?$B%a(B ?(IR(B) (?$B$b(B ?$B%b(B ?(IS(B) + (?$B$d(B ?$B%d(B ?(IT(B) (?$B$f(B ?$B%f(B ?(IU(B) (?$B$h(B ?$B%h(B ?(IV(B) + (?$B$i(B ?$B%i(B ?(IW(B) (?$B$j(B ?$B%j(B ?(IX(B) (?$B$k(B ?$B%k(B ?(IY(B) (?$B$l(B ?$B%l(B ?(IZ(B) (?$B$m(B ?$B%m(B ?(I[(B) + (?$B$o(B ?$B%o(B ?(I\(B) (?$B$p(B ?$B%p(B nil) (?$B$q(B ?$B%q(B nil) (?$B$r(B ?$B%r(B ?(I&(B) + (?$B$s(B ?$B%s(B ?(I](B) + (?$B$,(B ?$B%,(B "(I6^(B") (?$B$.(B ?$B%.(B "(I7^(B") (?$B$0(B ?$B%0(B "(I8^(B") (?$B$2(B ?$B%2(B "(I9^(B") (?$B$4(B ?$B%4(B "(I:^(B") + (?$B$6(B ?$B%6(B "(I;^(B") (?$B$8(B ?$B%8(B "(I<^(B") (?$B$:(B ?$B%:(B "(I=^(B") (?$B$<(B ?$B%<(B "(I>^(B") (?$B$>(B ?$B%>(B "(I?^(B") + (?$B$@(B ?$B%@(B "(I@^(B") (?$B$B(B ?$B%B(B "(IA^(B") (?$B$E(B ?$B%E(B "(IB^(B") (?$B$G(B ?$B%G(B "(IC^(B") (?$B$I(B ?$B%I(B "(ID^(B") + (?$B$P(B ?$B%P(B "(IJ^(B") (?$B$S(B ?$B%S(B "(IK^(B") (?$B$V(B ?$B%V(B "(IL^(B") (?$B$Y(B ?$B%Y(B "(IM^(B") (?$B$\(B ?$B%\(B "(IN^(B") + (?$B$Q(B ?$B%Q(B "(IJ_(B") (?$B$T(B ?$B%T(B "(IK_(B") (?$B$W(B ?$B%W(B "(IL_(B") (?$B$Z(B ?$B%Z(B "(IM_(B") (?$B$](B ?$B%](B "(IN_(B") + (?$B$!(B ?$B%!(B ?(I'(B) (?$B$#(B ?$B%#(B ?(I((B) (?$B$%(B ?$B%%(B ?(I)(B) (?$B$'(B ?$B%'(B ?(I*(B) (?$B$)(B ?$B%)(B ?(I+(B) + (?$B$C(B ?$B%C(B ?(I/(B) + (?$B$c(B ?$B%c(B ?(I,(B) (?$B$e(B ?$B%e(B ?(I-(B) (?$B$g(B ?$B%g(B ?(I.(B) + (?$B$n(B ?$B%n(B nil) + (nil ?$B%t(B "(I3^(B") (nil ?$B%u(B nil) (nil ?$B%v(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 + '((?\$B!!(B ?\ ) (?$B!"(B ?, ?(I$(B) (?$B!#(B ?. ?(I!(B) (?$B!$(B ?, ?(I$(B) (?$B!%(B ?. ?(I!(B) (?$B!&(B nil ?(I%(B) + (?$B!'(B ?:) (?$B!((B ?\;) (?$B!)(B ??) (?$B!*(B ?!) (?$B!+(B nil ?(I^(B) (?$B!,(B nil ?(I_(B) + (?$B!-(B ?') (?$B!.(B ?`) (?$B!0(B ?^) (?$B!2(B ?_) (?$B!<(B ?-) (?$B!=(B ?-) (?$B!>(B ?-) + (?$B!?(B ?/) (?$B!@(B ?\\) (?$B!A(B ?~) (?$B!C(B ?|) (?$B!F(B ?`) (?$B!G(B ?') (?$B!H(B ?\") (?$B!I(B ?\") + (?\$B!J(B ?\() (?\$B!K(B ?\)) (?\$B!N(B ?[) (?\$B!O(B ?]) (?\$B!P(B ?{) (?\$B!Q(B ?}) + (?$B!R(B ?<) (?$B!S(B ?>) (?$B!\(B ?+) (?$B!](B ?-) (?$B!a(B ?=) (?$B!c(B ?<) (?$B!d(B ?>) + (?$B!l(B ?') (?$B!m(B ?\") (?$B!o(B ?\\) (?$B!p(B ?$) (?$B!s(B ?%) (?$B!t(B ?#) (?$B!u(B ?&) (?$B!v(B ?*) + (?$B!w(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 + '((?$B#0(B . ?0) (?$B#1(B . ?1) (?$B#2(B . ?2) (?$B#3(B . ?3) (?$B#4(B . ?4) + (?$B#5(B . ?5) (?$B#6(B . ?6) (?$B#7(B . ?7) (?$B#8(B . ?8) (?$B#9(B . ?9) + (?$B#A(B . ?A) (?$B#B(B . ?B) (?$B#C(B . ?C) (?$B#D(B . ?D) (?$B#E(B . ?E) + (?$B#F(B . ?F) (?$B#G(B . ?G) (?$B#H(B . ?H) (?$B#I(B . ?I) (?$B#J(B . ?J) + (?$B#K(B . ?K) (?$B#L(B . ?L) (?$B#M(B . ?M) (?$B#N(B . ?N) (?$B#O(B . ?O) + (?$B#P(B . ?P) (?$B#Q(B . ?Q) (?$B#R(B . ?R) (?$B#S(B . ?S) (?$B#T(B . ?T) + (?$B#U(B . ?U) (?$B#V(B . ?V) (?$B#W(B . ?W) (?$B#X(B . ?X) (?$B#Y(B . ?Y) (?$B#Z(B . ?Z) + (?$B#a(B . ?a) (?$B#b(B . ?b) (?$B#c(B . ?c) (?$B#d(B . ?d) (?$B#e(B . ?e) + (?$B#f(B . ?f) (?$B#g(B . ?g) (?$B#h(B . ?h) (?$B#i(B . ?i) (?$B#j(B . ?j) + (?$B#k(B . ?k) (?$B#l(B . ?l) (?$B#m(B . ?m) (?$B#n(B . ?n) (?$B#o(B . ?o) + (?$B#p(B . ?p) (?$B#q(B . ?q) (?$B#r(B . ?r) (?$B#s(B . ?s) (?$B#t(B . ?t) + (?$B#u(B . ?u) (?$B#v(B . ?v) (?$B#w(B . ?w) (?$B#x(B . ?x) (?$B#y(B . ?y) (?$B#z(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 diff --git a/lisp/language/japanese.el b/lisp/language/japanese.el new file mode 100644 index 00000000000..f0dd5eb7be8 --- /dev/null +++ b/lisp/language/japanese.el @@ -0,0 +1,96 @@ +;;; 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 ($BF|K\8l(B) $B$3$s$K$A$O(B, (I:]FAJ(B"))) + +;;; japanese.el ends here diff --git a/lisp/language/korean.el b/lisp/language/korean.el new file mode 100644 index 00000000000..4fda60ac830 --- /dev/null +++ b/lisp/language/korean.el @@ -0,0 +1,78 @@ +;;; 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 ($(CGQ1[(B) $(C>H3gGO<<?d(B, $(C>H3gGO=J4O1n(B"))) + +;;; korean.el ends here diff --git a/lisp/language/misc-lang.el b/lisp/language/misc-lang.el new file mode 100644 index 00000000000..e0f6a969b4d --- /dev/null +++ b/lisp/language/misc-lang.el @@ -0,0 +1,31 @@ +;;; 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 diff --git a/lisp/language/thai-util.el b/lisp/language/thai-util.el new file mode 100644 index 00000000000..04685bf7553 --- /dev/null +++ b/lisp/language/thai-util.el @@ -0,0 +1,176 @@ +;; 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 '((?,T!(B consonant "LETTER KO KAI") ; 0xA1 + (?,T"(B consonant "LETTER KHO KHAI") ; 0xA2 + (?,T#(B consonant "LETTER KHO KHUAT") ; 0xA3 + (?,T$(B consonant "LETTER KHO KHWAI") ; 0xA4 + (?,T%(B consonant "LETTER KHO KHON") ; 0xA5 + (?,T&(B consonant "LETTER KHO RAKHANG") ; 0xA6 + (?,T'(B consonant "LETTER NGO NGU") ; 0xA7 + (?,T((B consonant "LETTER CHO CHAN") ; 0xA8 + (?,T)(B consonant "LETTER CHO CHING") ; 0xA9 + (?,T*(B consonant "LETTER CHO CHANG") ; 0xAA + (?,T+(B consonant "LETTER SO SO") ; 0xAB + (?,T,(B consonant "LETTER CHO CHOE") ; 0xAC + (?,T-(B consonant "LETTER YO YING") ; 0xAD + (?,T.(B consonant "LETTER DO CHADA") ; 0xAE + (?,T/(B consonant "LETTER TO PATAK") ; 0xAF + (?,T0(B consonant "LETTER THO THAN") ; 0xB0 + (?,T1(B consonant "LETTER THO NANGMONTHO") ; 0xB1 + (?,T2(B consonant "LETTER THO PHUTHAO") ; 0xB2 + (?,T3(B consonant "LETTER NO NEN") ; 0xB3 + (?,T4(B consonant "LETTER DO DEK") ; 0xB4 + (?,T5(B consonant "LETTER TO TAO") ; 0xB5 + (?,T6(B consonant "LETTER THO THUNG") ; 0xB6 + (?,T7(B consonant "LETTER THO THAHAN") ; 0xB7 + (?,T8(B consonant "LETTER THO THONG") ; 0xB8 + (?,T9(B consonant "LETTER NO NU") ; 0xB9 + (?,T:(B consonant "LETTER BO BAIMAI") ; 0xBA + (?,T;(B consonant "LETTER PO PLA") ; 0xBB + (?,T<(B consonant "LETTER PHO PHUNG") ; 0xBC + (?,T=(B consonant "LETTER FO FA") ; 0xBD + (?,T>(B consonant "LETTER PHO PHAN") ; 0xBE + (?,T?(B consonant "LETTER FO FAN") ; 0xBF + (?,T@(B consonant "LETTER PHO SAMPHAO") ; 0xC0 + (?,TA(B consonant "LETTER MO MA") ; 0xC1 + (?,TB(B consonant "LETTER YO YAK") ; 0xC2 + (?,TC(B consonant "LETTER RO RUA") ; 0xC3 + (?,TD(B vowel-base "LETTER RU (Pali vowel letter)") ; 0xC4 + (?,TE(B consonant "LETTER LO LING") ; 0xC5 + (?,TF(B vowel-base "LETTER LU (Pali vowel letter)") ; 0xC6 + (?,TG(B consonant "LETTER WO WAEN") ; 0xC7 + (?,TH(B consonant "LETTER SO SALA") ; 0xC8 + (?,TI(B consonant "LETTER SO RUSI") ; 0xC9 + (?,TJ(B consonant "LETTER SO SUA") ; 0xCA + (?,TK(B consonant "LETTER HO HIP") ; 0xCB + (?,TL(B consonant "LETTER LO CHULA") ; 0xCC + (?,TM(B consonant "LETTER O ANG") ; 0xCD + (?,TN(B consonant "LETTER HO NOK HUK") ; 0xCE + (?,TO(B special "PAI YAN NOI (abbreviation)") ; 0xCF + (?,TP(B vowel-base "VOWEL SIGN SARA A") ; 0xD0 + (?,TQ(B vowel-upper "VOWEL SIGN MAI HAN-AKAT N/S-T") ; 0xD1 + (?,TR(B vowel-base "VOWEL SIGN SARA AA") ; 0xD2 + (?,TS(B vowel-base "VOWEL SIGN SARA AM") ; 0xD3 + (?,TT(B vowel-upper "VOWEL SIGN SARA I N/S-T") ; 0xD4 + (?,TU(B vowel-upper "VOWEL SIGN SARA II N/S-T") ; 0xD5 + (?,TV(B vowel-upper "VOWEL SIGN SARA UE N/S-T") ; 0xD6 + (?,TW(B vowel-upper "VOWEL SIGN SARA UEE N/S-T") ; 0xD7 + (?,TX(B vowel-lower "VOWEL SIGN SARA U N/S-B") ; 0xD8 + (?,TY(B vowel-lower "VOWEL SIGN SARA UU N/S-B") ; 0xD9 + (?,TZ(B vowel-lower "VOWEL SIGN PHINTHU N/S-B (Pali virama)") ; 0xDA + (?,T[(B invalid nil) ; 0xDA + (?,T\(B invalid nil) ; 0xDC + (?,T](B invalid nil) ; 0xDC + (?,T^(B invalid nil) ; 0xDC + (?,T_(B special "BAHT SIGN (currency symbol)") ; 0xDF + (?,T`(B vowel-base "VOWEL SIGN SARA E") ; 0xE0 + (?,Ta(B vowel-base "VOWEL SIGN SARA AE") ; 0xE1 + (?,Tb(B vowel-base "VOWEL SIGN SARA O") ; 0xE2 + (?,Tc(B vowel-base "VOWEL SIGN SARA MAI MUAN") ; 0xE3 + (?,Td(B vowel-base "VOWEL SIGN SARA MAI MALAI") ; 0xE4 + (?,Te(B vowel-base "LAK KHANG YAO") ; 0xE5 + (?,Tf(B special "MAI YAMOK (repetion)") ; 0xE6 + (?,Tg(B vowel-upper "VOWEL SIGN MAI TAI KHU N/S-T") ; 0xE7 + (?,Th(B tone "TONE MAI EK N/S-T") ; 0xE8 + (?,Ti(B tone "TONE MAI THO N/S-T") ; 0xE9 + (?,Tj(B tone "TONE MAI TRI N/S-T") ; 0xEA + (?,Tk(B tone "TONE MAI CHATTAWA N/S-T") ; 0xEB + (?,Tl(B tone "THANTHAKHAT N/S-T (cancellation mark)") ; 0xEC + (?,Tm(B tone "NIKKHAHIT N/S-T (final nasal)") ; 0xED + (?,Tn(B vowel-upper "YAMAKKAN N/S-T") ; 0xEE + (?,To(B special "FONRMAN") ; 0xEF + (?,Tp(B special "DIGIT ZERO") ; 0xF0 + (?,Tq(B special "DIGIT ONE") ; 0xF1 + (?,Tr(B special "DIGIT TWO") ; 0xF2 + (?,Ts(B special "DIGIT THREE") ; 0xF3 + (?,Tt(B special "DIGIT FOUR") ; 0xF4 + (?,Tu(B special "DIGIT FIVE") ; 0xF5 + (?,Tv(B special "DIGIT SIX") ; 0xF6 + (?,Tw(B special "DIGIT SEVEN") ; 0xF7 + (?,Tx(B special "DIGIT EIGHT") ; 0xF8 + (?,Ty(B special "DIGIT NINE") ; 0xF9 + (?,Tz(B special "ANGKHANKHU (ellipsis)") ; 0xFA + (?,T{(B special "KHOMUT (beginning of religious texts)") ; 0xFB + (?,T|(B invalid nil) ; 0xFC + (?,T}(B invalid nil) ; 0xFD + (?,T~(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 + diff --git a/lisp/language/thai.el b/lisp/language/thai.el new file mode 100644 index 00000000000..848959674f1 --- /dev/null +++ b/lisp/language/thai.el @@ -0,0 +1,63 @@ +;;; 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 (,T@RIRd7B(B) ,TJ0GQ1J04U1$0CQ1:(B, ,TJ0GQ1J04U10$h1P(B"))) + +;;; thai.el ends here diff --git a/lisp/language/viet-util.el b/lisp/language/viet-util.el new file mode 100644 index 00000000000..6303f34dc9b --- /dev/null +++ b/lisp/language/viet-util.el @@ -0,0 +1,267 @@ +;; 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( -> ,1e(B +;; circumflex | ^ | a^ -> ,1b(B +;; horn | + | o+ -> ,1=(B +;; ------------+----------+--------- +;; acute | ' | a' -> ,1a(B +;; grave | ` | a` -> ,1`(B +;; hook above | ? | a? -> ,1d(B +;; tilde | ~ | a~ -> ,1c(B +;; dot below | . | a. -> ,1U(B +;; ------------+----------+--------- +;; d bar | dd | dd -> ,1p(B +;; ------------+----------+--------- + +(defvar viet-viqr-alist + '(;; lowercase + (?,1!(B . "a('") ; 161 + (?,1"(B . "a(`") ; 162 + (?,1#(B . "a(.") ; 163 + (?,1$(B . "a^'") ; 164 + (?,1%(B . "a^`") ; 165 + (?,1&(B . "a^?") ; 166 + (?,1'(B . "a^.") ; 167 + (?,1((B . "e~") ; 168 + (?,1)(B . "e.") ; 169 + (?,1*(B . "e^'") ; 170 + (?,1+(B . "e^`") ; 171 + (?,1,(B . "e^?") ; 172 + (?,1-(B . "e^~") ; 173 + (?,1.(B . "e^.") ; 174 + (?,1/(B . "o^'") ; 175 + (?,10(B . "o^`") ; 176 + (?,11(B . "o^?") ; 177 + (?,12(B . "o^~") ; 178 + (?,15(B . "o^.") ; 181 + (?,16(B . "o+`") ; 182 + (?,17(B . "o+?") ; 183 + (?,18(B . "i.") ; 184 + (?,1=(B . "o+") ; 189 + (?,1>(B . "o+'") ; 190 + (?,1F(B . "a(?") ; 198 + (?,1G(B . "a(~") ; 199 + (?,1O(B . "y`") ; 207 + (?,1Q(B . "u+'") ; 209 + (?,1U(B . "a.") ; 213 + (?,1V(B . "y?") ; 214 + (?,1W(B . "u+`") ; 215 + (?,1X(B . "u+?") ; 216 + (?,1[(B . "y~") ; 219 + (?,1\(B . "y.") ; 220 + (?,1^(B . "o+~") ; 222 + (?,1_(B . "u+") ; 223 + (?,1`(B . "a`") ; 224 + (?,1a(B . "a'") ; 225 + (?,1b(B . "a^") ; 226 + (?,1c(B . "a~") ; 227 + (?,1d(B . "a?") ; 228 + (?,1e(B . "a(") ; 229 + (?,1f(B . "u+~") ; 230 + (?,1g(B . "a^~") ; 231 + (?,1h(B . "e`") ; 232 + (?,1i(B . "e'") ; 233 + (?,1j(B . "e^") ; 234 + (?,1k(B . "e?") ; 235 + (?,1l(B . "i`") ; 236 + (?,1m(B . "i'") ; 237 + (?,1n(B . "i~") ; 238 + (?,1o(B . "i?") ; 239 + (?,1p(B . "dd") ; 240 + (?,1q(B . "u+.") ; 241 + (?,1r(B . "o`") ; 242 + (?,1s(B . "o'") ; 243 + (?,1t(B . "o^") ; 244 + (?,1u(B . "o~") ; 245 + (?,1v(B . "o?") ; 246 + (?,1w(B . "o.") ; 247 + (?,1x(B . "u.") ; 248 + (?,1y(B . "u`") ; 249 + (?,1z(B . "u'") ; 250 + (?,1{(B . "u~") ; 251 + (?,1|(B . "u?") ; 252 + (?,1}(B . "y'") ; 253 + (?,1~(B . "o+.") ; 254 + + ;; upper case + (?,2!(B . "A('") ; 161 + (?,2"(B . "A(`") ; 162 + (?,2#(B . "A(.") ; 163 + (?,2$(B . "A^'") ; 164 + (?,2%(B . "A^`") ; 165 + (?,2&(B . "A^?") ; 166 + (?,2'(B . "A^.") ; 167 + (?,2((B . "E~") ; 168 + (?,2)(B . "E.") ; 169 + (?,2*(B . "E^'") ; 170 + (?,2+(B . "E^`") ; 171 + (?,2,(B . "E^?") ; 172 + (?,2-(B . "E^~") ; 173 + (?,2.(B . "E^.") ; 174 + (?,2/(B . "O^'") ; 175 + (?,20(B . "O^`") ; 176 + (?,21(B . "O^?") ; 177 + (?,22(B . "O^~") ; 178 + (?,25(B . "O^.") ; 181 + (?,26(B . "O+`") ; 182 + (?,27(B . "O+?") ; 183 + (?,28(B . "I.") ; 184 + (?,2=(B . "O+") ; 189 + (?,2>(B . "O+'") ; 190 + (?,2F(B . "A(?") ; 198 + (?,2G(B . "A(~") ; 199 + (?,2O(B . "Y`") ; 207 + (?,2Q(B . "U+'") ; 209 + (?,2U(B . "A.") ; 213 + (?,2V(B . "Y?") ; 214 + (?,2W(B . "U+`") ; 215 + (?,2X(B . "U+?") ; 216 + (?,2[(B . "Y~") ; 219 + (?,2\(B . "Y.") ; 220 + (?,2^(B . "O+~") ; 222 + (?,2_(B . "U+") ; 223 + (?,2`(B . "A`") ; 224 + (?,2a(B . "A'") ; 225 + (?,2b(B . "A^") ; 226 + (?,2c(B . "A~") ; 227 + (?,2d(B . "A?") ; 228 + (?,2e(B . "A(") ; 229 + (?,2f(B . "U+~") ; 230 + (?,2g(B . "A^~") ; 231 + (?,2h(B . "E`") ; 232 + (?,2i(B . "E'") ; 233 + (?,2j(B . "E^") ; 234 + (?,2k(B . "E?") ; 235 + (?,2l(B . "I`") ; 236 + (?,2m(B . "I'") ; 237 + (?,2n(B . "I~") ; 238 + (?,2o(B . "I?") ; 239 + (?,2p(B . "DD") ; 240 + (?,2p(B . "dD") ; 240 + (?,2p(B . "Dd") ; 240 + (?,2q(B . "U+.") ; 241 + (?,2r(B . "O`") ; 242 + (?,2s(B . "O'") ; 243 + (?,2t(B . "O^") ; 244 + (?,2u(B . "O~") ; 245 + (?,2v(B . "O?") ; 246 + (?,2w(B . "O.") ; 247 + (?,2x(B . "U.") ; 248 + (?,2y(B . "U`") ; 249 + (?,2z(B . "U'") ; 250 + (?,2{(B . "U~") ; 251 + (?,2|(B . "U?") ; 252 + (?,2}(B . "Y'") ; 253 + (?,2~(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 diff --git a/lisp/language/vietnamese.el b/lisp/language/vietnamese.el new file mode 100644 index 00000000000..bb14a4f580c --- /dev/null +++ b/lisp/language/vietnamese.el @@ -0,0 +1,254 @@ +;;; 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 ?,2F(B 3 4 ?,2G(B ?,2g(B 7 8 9 10 11 12 13 14 15 + 16 17 18 19 ?,2V(B 21 22 23 24 ?,2[(B 26 27 28 29 ?,2\(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 + ?,2U(B ?,2!(B ?,2"(B ?,2#(B ?,2$(B ?,2%(B ?,2&(B ?,2'(B ?,2((B ?,2)(B ?,2*(B ?,2+(B ?,2,(B ?,2-(B ?,2.(B ?,2/(B + ?,20(B ?,21(B ?,22(B ?,25(B ?,2~(B ?,2>(B ?,26(B ?,27(B ?,28(B ?,2v(B ?,2w(B ?,2o(B ?,2|(B ?,2{(B ?,2x(B ?,2O(B + ?,2u(B ?,1!(B ?,1"(B ?,1#(B ?,1$(B ?,1%(B ?,1&(B ?,1'(B ?,1((B ?,1)(B ?,1*(B ?,1+(B ?,1,(B ?,1-(B ?,1.(B ?,1/(B + ?,10(B ?,11(B ?,12(B ?,2^(B ?,2=(B ?,15(B ?,16(B ?,17(B ?,18(B ?,2q(B ?,2Q(B ?,2W(B ?,2X(B ?,1=(B ?,1>(B ?,2_(B + ?,2`(B ?,2a(B ?,2b(B ?,2c(B ?,2d(B ?,2e(B ?,1F(B ?,1G(B ?,2h(B ?,2i(B ?,2j(B ?,2k(B ?,2l(B ?,2m(B ?,2n(B ?,1O(B + ?,2p(B ?,1Q(B ?,2r(B ?,2s(B ?,2t(B ?,1U(B ?,1V(B ?,1W(B ?,1X(B ?,2y(B ?,2z(B ?,1[(B ?,1\(B ?,2}(B ?,1^(B ?,1_(B + ?,1`(B ?,1a(B ?,1b(B ?,1c(B ?,1d(B ?,1e(B ?,1f(B ?,1g(B ?,1h(B ?,1i(B ?,1j(B ?,1k(B ?,1l(B ?,1m(B ?,1n(B ?,1o(B + ?,1p(B ?,1q(B ?,1r(B ?,1s(B ?,1t(B ?,1u(B ?,1v(B ?,1w(B ?,1x(B ?,1y(B ?,1z(B ?,1{(B ?,1|(B ?,1}(B ?,1~(B ?,2f(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 ?,2z(B ?,2x(B 3 ?,2W(B ?,2X(B ?,2f(B 7 8 9 10 11 12 13 14 15 + 16 ?,2Q(B ?,2_(B ?,2O(B ?,2V(B ?,2[(B ?,2}(B ?,2\(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 + ?,2`(B ?,2d(B ?,2c(B ?,2a(B ?,2U(B ?,2#(B ?,2'(B ?,2h(B ?,2k(B ?,2((B ?,2i(B ?,2)(B ?,2.(B ?,2l(B ?,2o(B ?,2n(B + ?,2m(B ?,28(B ?,2r(B ?,2v(B ?,2u(B ?,2s(B ?,2w(B ?,25(B ?,26(B ?,27(B ?,2^(B ?,2>(B ?,2~(B ?,2y(B ?,2|(B ?,2{(B + 160 ?,2e(B ?,2b(B ?,2j(B ?,2t(B ?,2=(B ?,2_(B ?,2p(B ?,1e(B ?,1b(B ?,1j(B ?,1t(B ?,1>(B ?,1y(B ?,1p(B ?,2"(B + 192 193 194 195 196 ?,1`(B ?,1d(B ?,1c(B ?,1a(B ?,1U(B ?,2F(B ?,1"(B ?,1F(B ?,1G(B ?,1!(B ?,2G(B + ?,2!(B ?,2%(B ?,2&(B ?,2g(B ?,2%(B ?,2+(B ?,1#(B ?,1%(B ?,1&(B ?,1g(B ?,1$(B ?,1'(B ?,1h(B ?,2,(B ?,1k(B ?,1((B + ?,1i(B ?,1)(B ?,1+(B ?,1,(B ?,1-(B ?,1*(B ?,1.(B ?,1l(B ?,1o(B ?,2-(B ?,2*(B ?,20(B ?,1n(B ?,1m(B ?,18(B ?,1r(B + ?,21(B ?,1v(B ?,1u(B ?,1s(B ?,1w(B ?,10(B ?,11(B ?,12(B ?,1/(B ?,15(B ?,16(B ?,17(B ?,1^(B ?,1>(B ?,1~(B ?,1y(B + ?,22(B ?,1|(B ?,1{(B ?,1z(B ?,1x(B ?,1W(B ?,1X(B ?,1f(B ?,1Q(B ?,1q(B ?,1O(B ?,1V(B ?,1[(B ?,1}(B ?,1\(B ?,2/(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,1*(Bng Vi,1.(Bt) Ch,1`(Bo b,1U(Bn"))) + +;;; vietnamese.el ends here diff --git a/src/category.c b/src/category.c new file mode 100644 index 00000000000..8bdaee9e5af --- /dev/null +++ b/src/category.c @@ -0,0 +1,665 @@ +/* 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; + + +/* 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; +} + + +/* 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; +} + + +/* 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; +} + + +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; +} + +/* 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; +} + +/* 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; +} + + +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; +} diff --git a/src/category.h b/src/category.h new file mode 100644 index 00000000000..975e82b52f2 --- /dev/null +++ b/src/category.h @@ -0,0 +1,130 @@ +/* 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)) diff --git a/src/ccl.c b/src/ccl.c new file mode 100644 index 00000000000..11c1ae500d6 --- /dev/null +++ b/src/ccl.c @@ -0,0 +1,1140 @@ +/* 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 */ diff --git a/src/ccl.h b/src/ccl.h new file mode 100644 index 00000000000..ebda0cc1595 --- /dev/null +++ b/src/ccl.h @@ -0,0 +1,53 @@ +/* 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 */ diff --git a/src/charset.c b/src/charset.c new file mode 100644 index 00000000000..b962f346f22 --- /dev/null +++ b/src/charset.c @@ -0,0 +1,1452 @@ +/* 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; +} + +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 */ + +/*** 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); +} + + +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 */ diff --git a/src/charset.h b/src/charset.h new file mode 100644 index 00000000000..677a5755adf --- /dev/null +++ b/src/charset.h @@ -0,0 +1,649 @@ +/* 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 */ + diff --git a/src/coding.c b/src/coding.c new file mode 100644 index 00000000000..95bbd26fef9 --- /dev/null +++ b/src/coding.c @@ -0,0 +1,3520 @@ +/* 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) + + +/*** 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; + + +/*** 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; +} + + +/*** 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; +} + + +/*** 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; +} + + +/*** 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; +} + + +/*** 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; +} + + +#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; +} + + +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 */ + + +/*** 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 */ diff --git a/src/coding.h b/src/coding.h new file mode 100644 index 00000000000..3ec2fcc32f3 --- /dev/null +++ b/src/coding.h @@ -0,0 +1,409 @@ +/* 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 */ diff --git a/src/fontset.c b/src/fontset.c new file mode 100644 index 00000000000..7d88e90ae89 --- /dev/null +++ b/src/fontset.c @@ -0,0 +1,819 @@ +/* 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); +} diff --git a/src/fontset.h b/src/fontset.h new file mode 100644 index 00000000000..902f1691d6f --- /dev/null +++ b/src/fontset.h @@ -0,0 +1,201 @@ +/* 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 */ |