1 ;;; mule-category.el --- category functions for XEmacs/Mule.
3 ;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995, 1997, 1999 Electrotechnical Laboratory, JAPAN.
5 ;; Licensed to the Free Software Foundation.
6 ;; Copyright (C) 1995 Amdahl Corporation.
7 ;; Copyright (C) 1995 Sun Microsystems.
8 ;; Copyright (C) 2003 MORIOKA Tomohiko
10 ;; This file is part of XEmacs.
12 ;; XEmacs is free software; you can redistribute it and/or modify it
13 ;; under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
17 ;; XEmacs is distributed in the hope that it will be useful, but
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;; General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with XEmacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
29 ;; Functions for working with category tables, which are a particular
30 ;; type of char table. Some function names / arguments should be
31 ;; parallel with syntax tables.
33 ;; Written by Ben Wing <ben@xemacs.org>. The initialization code
34 ;; at the end of this file comes from Mule.
35 ;; Some bugfixes by Jareth Hein <jhod@po.iijnet.or.jp>
39 (defvar defined-category-hashtable (make-hash-table :size 50))
41 (defun define-category (designator doc-string)
42 "Make a new category whose designator is DESIGNATOR.
43 DESIGNATOR should be a visible letter of ' ' thru '~'.
44 STRING is a doc string for the category.
45 Letters of 'a' thru 'z' are already used or kept for the system."
46 (check-argument-type 'category-designator-p designator)
47 (check-argument-type 'stringp doc-string)
48 (puthash designator doc-string defined-category-hashtable))
50 (defun undefine-category (designator)
51 "Undefine DESIGNATOR as a designator for a category."
52 (check-argument-type 'category-designator-p designator)
53 (remhash designator defined-category-hashtable))
55 (defun defined-category-p (designator)
56 "Return non-nil if DESIGNATOR is a designator for a defined category."
57 (and (category-designator-p designator)
58 (gethash designator defined-category-hashtable)))
60 (defun defined-category-list ()
61 "Return a list of the currently defined categories.
62 Categories are given by their designators."
64 (maphash #'(lambda (key value)
65 (setq list (cons key list)))
66 defined-category-hashtable)
69 (defun undefined-category-designator ()
70 "Return an undefined category designator, or nil if there are none."
72 (while (and (< a 127) (not found))
73 (unless (gethash a defined-category-hashtable)
74 (setq found (make-char 'ascii a)))
78 (defun category-doc-string (designator)
79 "Return the doc-string for the category denoted by DESIGNATOR."
80 (check-argument-type 'defined-category-p designator)
81 (gethash designator defined-category-hashtable))
83 (defun modify-category-entry (char-range designator &optional category-table reset)
84 "Add a category to the categories associated with CHAR-RANGE.
85 CHAR-RANGE is a single character or a range of characters,
86 as per `put-char-table'.
87 The category is given by a designator character.
88 The changes are made in CATEGORY-TABLE, which defaults to the current
89 buffer's category table.
90 If optional fourth argument RESET is non-nil, previous categories associated
91 with CHAR-RANGE are removed before adding the specified category."
92 (or category-table (setq category-table (category-table)))
93 (check-argument-type 'category-table-p category-table)
94 (check-argument-type 'defined-category-p designator)
96 ;; clear all existing stuff.
97 (put-char-table char-range nil category-table))
100 ;; make sure that this range has a bit-vector assigned to it
101 (if (not (bit-vector-p value))
102 (setq value (make-bit-vector 95 0))
103 (setq value (copy-sequence value)))
104 ;; set the appropriate bit in that vector.
105 (aset value (- designator 32) 1)
106 ;; put the vector back, thus assuring we have a unique setting for this range
107 (put-char-table key value category-table))
108 category-table char-range))
110 (defun char-category-list (character &optional category-table)
111 "Return a list of the categories that CHARACTER is in.
112 CATEGORY-TABLE defaults to the current buffer's category table.
113 The categories are given by their designators."
114 (or category-table (setq category-table (category-table)))
115 (check-argument-type 'category-table-p category-table)
116 (let ((vec (get-char-table character category-table)))
120 (if (= 1 (aref vec (- a 32)))
121 (setq list (cons (make-char 'ascii a) list)))
125 ;; implemented in C, file chartab.c (97/3/14 jhod@po.iijnet.or.jp)
126 ;(defun char-in-category-p (char category &optional table)
127 ; "Return non-nil if CHAR is in CATEGORY.
128 ;TABLE defaults to the current buffer's category table.
129 ;Categories are specified by their designators."
130 ; (or table (setq table (category-table)))
131 ; (check-argument-type 'category-table-p table)
132 ; (check-argument-type 'category-designator-p category)
133 ; (let ((vec (get-char-table char table)))
135 ; (= 1 (aref vec (- category 32))))))
137 (defun describe-category ()
138 "Describe the category specifications in the category table.
139 The descriptions are inserted in a buffer, which is then displayed."
141 (with-displaying-help-buffer
143 (describe-category-table (category-table) standard-output))))
145 (defun describe-category-table (table stream)
150 (lambda (first last value stream)
151 (if (and (bit-vector-p value)
152 (> (reduce '+ value) 0))
154 (if (equal first last)
155 (cond ((vectorp first)
156 (princ (format "%s, row %d"
162 (princ (charset-name first) stream))
163 (t (princ first stream)))
164 (cond ((vectorp first)
165 (princ (format "%s, rows %d .. %d"
172 (princ (format "%s .. %s" first last)
174 (describe-category-code value stream))))))
176 (lambda (range value)
178 (and (characterp range)
179 (characterp first-char)
180 (eq (char-charset range) (char-charset first-char))
181 (= (char-to-int last-char) (1- (char-to-int range))))
184 (eq (aref range 0) (aref first-char 0))
185 (= (aref last-char 1) (1- (aref range 1))))
186 (equal value prev-val)))
187 (setq last-char range)
190 (funcall describe-one first-char last-char prev-val stream)
191 (setq first-char nil)))
192 (funcall describe-one range range value stream))
196 (funcall describe-one first-char last-char prev-val stream))))
198 (defun describe-category-code (code stream)
199 (let ((standard-output (or stream standard-output)))
200 (princ "\tin categories: ")
201 (if (not (bit-vector-p code))
206 (if (= 1 (aref code i))
208 (if (not already-matched)
209 (setq already-matched t)
211 (princ (int-to-char (+ 32 i)))))
213 (if (not already-matched)
217 (if (= 1 (aref code i))
218 (princ (format "\n\t\tmeaning: %s"
219 (category-doc-string (int-to-char (+ 32 i))))))
223 (defconst predefined-category-list
224 '((latin-iso8859-1 ?l "Latin-1 through Latin-5 character set")
229 (cyrillic-iso8859-5 ?y "Cyrillic character set")
230 (arabic-iso8859-6 ?b "Arabic character set")
231 (greek-iso8859-7 ?g "Greek character set")
232 (hebrew-iso8859-8 ?w "Hebrew character set")
233 (katakana-jisx0201 ?k "Japanese 1-byte Katakana character set")
234 (latin-jisx0201 ?r "Japanese 1-byte Roman character set")
235 (japanese-jisx0208-1978 ?j "Japanese 2-byte character set (old)")
236 (japanese-jisx0208 ?j "Japanese 2-byte character set")
237 (japanese-jisx0212 ?j)
238 (chinese-gb2312 ?c "Chinese GB (China, PRC) 2-byte character set")
239 (chinese-cns11643-1 ?t "Chinese Taiwan (CNS or Big5) 2-byte character set")
240 (chinese-cns11643-2 ?t)
243 (korean-ksc5601 ?h "Hangul (Korean) 2-byte character set")
245 "List of predefined categories.
246 Each element is a list of a charset, a designator, and maybe a doc string.")
249 (define-category ?a "ASCII character set.")
250 (define-category ?l "Latin-1 through Latin-5 character set")
253 (modify-category-entry i ?a)
254 (modify-category-entry i ?l)
256 (setq l predefined-category-list)
258 (if (and (nth 2 (car l))
259 (not (defined-category-p (nth 2 (car l)))))
260 (define-category (nth 1 (car l)) (nth 2 (car l))))
261 (modify-category-entry (car (car l)) (nth 1 (car l)))
264 ;;; Setting word boundary.
266 (unless (featurep 'utf-2000)
267 (setq word-combining-categories
271 (setq word-separating-categories ; (2-byte character sets)
272 '((?A . ?K) ; Alpha numeric - Katakana
273 (?A . ?C) ; Alpha numeric - Chinese
274 (?H . ?A) ; Hiragana - Alpha numeric
275 (?H . ?K) ; Hiragana - Katakana
276 (?H . ?C) ; Hiragana - Chinese
277 (?K . ?A) ; Katakana - Alpha numeric
278 (?K . ?C) ; Katakana - Chinese
279 (?C . ?A) ; Chinese - Alpha numeric
280 (?C . ?K) ; Chinese - Katakana
283 (when (featurep 'utf-2000)
284 (setq word-separating-categories
286 '(?l . ?K) ; Latin - Katakana
287 '(?l . ?C) ; Latin - Chinese
288 '(?H . ?l) ; Hiragana - Latin
289 '(?K . ?l) ; Katakana - Latin
290 '(?C . ?l) ; Chinese - Latin
291 word-separating-categories)))
294 ;;; At the present, I know Japanese and Chinese text can
295 ;;; break line at any point under a restriction of 'kinsoku'.
296 ;;; #### SJT this needs to be set by language environments and probably should
297 ;;; be buffer-local---strategy for dealing with this: check all $language.el
298 ;;; files and also mule-base/$language-utils.el files for variables set;
299 ;;; these should be made buffer local and some kind of a- or p-list of vars
300 ;;; to be set for a language environment created.
301 (defvar word-across-newline "\\(\\cj\\|\\cc\\|\\ct\\)"
302 "Regular expression of such characters which can be a word across newline.")
304 (defvar ascii-char "[\40-\176]")
305 (defvar ascii-space "[ \t]")
306 (defvar ascii-symbols "[\40-\57\72-\100\133-\140\173-\176]")
307 (defvar ascii-numeric "[\60-\71]")
308 (defvar ascii-English-Upper "[\101-\132]")
309 (defvar ascii-English-Lower "[\141-\172]")
310 (defvar ascii-alphanumeric "[\60-\71\101-\132\141-\172]")
312 (defvar kanji-char "\\cj")
313 (defvar kanji-space "
\e$B!!
\e(B")
314 (defvar kanji-symbols "\\cS")
315 (defvar kanji-numeric "[
\e$B#0
\e(B-
\e$B#9
\e(B]")
316 (defvar kanji-English-Upper "[
\e$B#A
\e(B-
\e$B#Z
\e(B]")
317 (defvar kanji-English-Lower "[
\e$B#a
\e(B-
\e$B#z
\e(B]")
318 (defvar kanji-hiragana "\\cH")
319 (defvar kanji-katakana "\\cK")
320 (defvar kanji-Greek-Upper "[
\e$B&!
\e(B-
\e$B&8
\e(B]")
321 (defvar kanji-Greek-Lower "[
\e$B&A
\e(B-
\e$B&X
\e(B]")
322 (defvar kanji-Russian-Upper "[
\e$B'!
\e(B-
\e$B'A
\e(B]")
323 (defvar kanji-Russian-Lower "[
\e$B'Q
\e(B-
\e$B'q
\e(B]")
324 (defvar kanji-Kanji-1st-Level "[
\e$B0!
\e(B-
\e$BOS
\e(B]")
325 (defvar kanji-Kanji-2nd-Level "[
\e$BP!
\e(B-
\e$Bt$
\e(B]")
327 (defvar kanji-kanji-char "\\(\\cH\\|\\cK\\|\\cC\\)")