Mercurial > hg > xemacs-beta
annotate lisp/mule/mule-category.el @ 5384:3889ef128488
Fix misspelled words, and some grammar, across the entire source tree.
See xemacs-patches message with ID
<AANLkTi=edkEKtK3pZ60ytsG5pTJQy2TjAEVCZCLOa-oA@mail.gmail.com>.
| author | Jerry James <james@xemacs.org> |
|---|---|
| date | Thu, 24 Mar 2011 11:00:11 -0600 |
| parents | 311f6817efc2 |
| children | ac37a5f7e5be |
| rev | line source |
|---|---|
| 502 | 1 ;;; mule-category.el --- category functions for XEmacs/Mule. -*- coding: iso-2022-7bit; -*- |
| 428 | 2 |
| 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 | |
| 9 ;; This file is part of XEmacs. | |
| 10 | |
| 11 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 12 ;; under the terms of the GNU General Public License as published by | |
| 13 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 14 ;; any later version. | |
| 15 | |
| 16 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 19 ;; General Public License for more details. | |
| 20 | |
| 21 ;; You should have received a copy of the GNU General Public License | |
| 444 | 22 ;; along with XEmacs; see the file COPYING. If not, write to the |
| 428 | 23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
| 24 ;; Boston, MA 02111-1307, USA. | |
| 25 | |
| 26 ;;; Commentary: | |
| 27 | |
| 28 ;; Functions for working with category tables, which are a particular | |
| 29 ;; type of char table. Some function names / arguments should be | |
| 30 ;; parallel with syntax tables. | |
| 31 | |
| 32 ;; Written by Ben Wing <ben@xemacs.org>. The initialization code | |
| 33 ;; at the end of this file comes from Mule. | |
| 34 ;; Some bugfixes by Jareth Hein <jhod@po.iijnet.or.jp> | |
| 35 | |
| 36 ;;; Code: | |
| 37 | |
| 442 | 38 (defvar defined-category-hashtable (make-hash-table :size 50)) |
| 428 | 39 |
| 3970 | 40 (defun define-category (designator doc-string &optional table) |
| 428 | 41 "Make a new category whose designator is DESIGNATOR. |
| 42 DESIGNATOR should be a visible letter of ' ' thru '~'. | |
| 3970 | 43 DOC-STRING is a doc string for the category. |
| 44 Letters of 'a' thru 'z' are already used or kept for the system. | |
| 45 The category should be defined only in category table TABLE, which defaults | |
| 46 to the current buffer's category table, but this is not implemented. " | |
| 47 ;; #### Implement the limiting of the definition. | |
| 428 | 48 (check-argument-type 'category-designator-p designator) |
| 49 (check-argument-type 'stringp doc-string) | |
| 3970 | 50 (setq table (or table (category-table))) |
| 51 (check-argument-type 'category-table-p table) | |
| 428 | 52 (puthash designator doc-string defined-category-hashtable)) |
| 53 | |
| 54 (defun undefine-category (designator) | |
| 55 "Undefine DESIGNATOR as a designator for a category." | |
| 56 (check-argument-type 'category-designator-p designator) | |
| 57 (remhash designator defined-category-hashtable)) | |
| 58 | |
| 59 (defun defined-category-p (designator) | |
| 60 "Return non-nil if DESIGNATOR is a designator for a defined category." | |
| 61 (and (category-designator-p designator) | |
| 62 (gethash designator defined-category-hashtable))) | |
| 63 | |
| 64 (defun defined-category-list () | |
| 65 "Return a list of the currently defined categories. | |
| 66 Categories are given by their designators." | |
|
5363
311f6817efc2
Remove various redundant wrapper lambdas, core lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4805
diff
changeset
|
67 (hash-table-key-list defined-category-hashtable)) |
| 428 | 68 |
| 69 (defun undefined-category-designator () | |
| 70 "Return an undefined category designator, or nil if there are none." | |
| 71 (let ((a 32) found) | |
| 72 (while (and (< a 127) (not found)) | |
| 434 | 73 (unless (gethash a defined-category-hashtable) |
| 74 (setq found (make-char 'ascii a))) | |
| 428 | 75 (setq a (1+ a))) |
| 76 found)) | |
| 77 | |
| 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)) | |
| 82 | |
| 444 | 83 (defun modify-category-entry (char-range designator &optional category-table reset) |
| 428 | 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. | |
| 444 | 88 The changes are made in CATEGORY-TABLE, which defaults to the current |
| 89 buffer's category table. | |
| 428 | 90 If optional fourth argument RESET is non-nil, previous categories associated |
| 91 with CHAR-RANGE are removed before adding the specified category." | |
| 444 | 92 (or category-table (setq category-table (category-table))) |
| 93 (check-argument-type 'category-table-p category-table) | |
| 428 | 94 (check-argument-type 'defined-category-p designator) |
| 95 (if reset | |
| 96 ;; clear all existing stuff. | |
| 444 | 97 (put-char-table char-range nil category-table)) |
| 428 | 98 (map-char-table |
| 99 #'(lambda (key value) | |
| 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 | |
| 444 | 107 (put-char-table key value category-table)) |
| 108 category-table char-range)) | |
| 428 | 109 |
| 444 | 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. | |
| 428 | 113 The categories are given by their designators." |
| 444 | 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))) | |
| 428 | 117 (if (null vec) nil |
| 118 (let ((a 32) list) | |
| 119 (while (< a 127) | |
| 120 (if (= 1 (aref vec (- a 32))) | |
| 434 | 121 (setq list (cons (make-char 'ascii a) list))) |
| 428 | 122 (setq a (1+ a))) |
| 123 (nreverse list))))) | |
| 124 | |
| 444 | 125 ;; implemented in C, file chartab.c (97/3/14 jhod@po.iijnet.or.jp) |
| 428 | 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))) | |
| 134 ; (if (null vec) nil | |
| 135 ; (= 1 (aref vec (- category 32)))))) | |
| 136 | |
| 788 | 137 (put 'with-category-table 'lisp-indent-function 1) |
| 138 | |
| 139 (defmacro with-category-table (category-table &rest body) | |
| 140 `(let ((current-category-table (category-table))) | |
| 141 (set-category-table ,category-table) | |
| 142 (unwind-protect | |
| 143 (progn ,@body) | |
| 144 (set-category-table current-category-table)))) | |
| 145 | |
| 3970 | 146 (defun make-category-table () |
| 147 "Construct a new and empty category table and return it." | |
| 148 (make-char-table 'category)) | |
| 149 | |
| 428 | 150 (defun describe-category () |
| 151 "Describe the category specifications in the category table. | |
| 152 The descriptions are inserted in a buffer, which is then displayed." | |
| 153 (interactive) | |
| 434 | 154 (with-displaying-help-buffer |
| 155 (lambda () | |
| 156 (describe-category-table (category-table) standard-output)))) | |
| 428 | 157 |
| 158 (defun describe-category-table (table stream) | |
| 159 (let (first-char | |
| 160 last-char | |
| 161 prev-val | |
| 162 (describe-one | |
| 163 (lambda (first last value stream) | |
| 164 (if (and (bit-vector-p value) | |
| 165 (> (reduce '+ value) 0)) | |
| 166 (progn | |
| 167 (if (equal first last) | |
| 168 (cond ((vectorp first) | |
| 169 (princ (format "%s, row %d" | |
| 170 (charset-name | |
| 171 (aref first 0)) | |
| 172 (aref first 1)) | |
| 173 stream)) | |
| 174 ((charsetp first) | |
| 175 (princ (charset-name first) stream)) | |
| 176 (t (princ first stream))) | |
| 177 (cond ((vectorp first) | |
| 178 (princ (format "%s, rows %d .. %d" | |
| 179 (charset-name | |
| 180 (aref first 0)) | |
| 181 (aref first 1) | |
| 182 (aref last 1)) | |
| 183 stream)) | |
| 184 (t | |
| 185 (princ (format "%s .. %s" first last) | |
| 186 stream)))) | |
| 187 (describe-category-code value stream)))))) | |
| 188 (map-char-table | |
| 189 (lambda (range value) | |
| 190 (if (and (or | |
| 191 (and (characterp range) | |
| 192 (characterp first-char) | |
| 193 (eq (char-charset range) (char-charset first-char)) | |
| 194 (= (char-to-int last-char) (1- (char-to-int range)))) | |
| 195 (and (vectorp range) | |
| 196 (vectorp first-char) | |
| 197 (eq (aref range 0) (aref first-char 0)) | |
| 198 (= (aref last-char 1) (1- (aref range 1)))) | |
| 199 (equal value prev-val))) | |
| 200 (setq last-char range) | |
| 201 (if first-char | |
| 202 (progn | |
| 203 (funcall describe-one first-char last-char prev-val stream) | |
| 204 (setq first-char nil))) | |
| 205 (funcall describe-one range range value stream)) | |
| 206 nil) | |
| 207 table) | |
| 208 (if first-char | |
| 209 (funcall describe-one first-char last-char prev-val stream)))) | |
| 210 | |
| 211 (defun describe-category-code (code stream) | |
| 212 (let ((standard-output (or stream standard-output))) | |
| 213 (princ "\tin categories: ") | |
| 214 (if (not (bit-vector-p code)) | |
| 215 (princ "(none)") | |
| 216 (let ((i 0) | |
| 217 already-matched) | |
| 218 (while (< i 95) | |
| 219 (if (= 1 (aref code i)) | |
| 220 (progn | |
| 221 (if (not already-matched) | |
| 222 (setq already-matched t) | |
| 223 (princ " ")) | |
| 224 (princ (int-to-char (+ 32 i))))) | |
| 225 (setq i (1+ i))) | |
| 226 (if (not already-matched) | |
| 227 (princ "(none)"))) | |
| 228 (let ((i 0)) | |
| 229 (while (< i 95) | |
| 230 (if (= 1 (aref code i)) | |
| 231 (princ (format "\n\t\tmeaning: %s" | |
| 232 (category-doc-string (int-to-char (+ 32 i)))))) | |
| 233 (setq i (1+ i))))) | |
| 234 (terpri))) | |
| 235 | |
| 236 (defconst predefined-category-list | |
| 237 '((latin-iso8859-1 ?l "Latin-1 through Latin-5 character set") | |
| 238 (latin-iso8859-2 ?l) | |
| 239 (latin-iso8859-3 ?l) | |
| 240 (latin-iso8859-4 ?l) | |
| 241 (latin-iso8859-9 ?l) | |
| 242 (cyrillic-iso8859-5 ?y "Cyrillic character set") | |
|
4805
980575c76541
Move the arabic-iso8859-6 character set back to C, otherwise X11 lookup fails.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4491
diff
changeset
|
243 (arabic-iso8859-6 ?b "Arabic character set") |
| 428 | 244 (greek-iso8859-7 ?g "Greek character set") |
| 245 (hebrew-iso8859-8 ?w "Hebrew character set") | |
| 246 (katakana-jisx0201 ?k "Japanese 1-byte Katakana character set") | |
| 247 (latin-jisx0201 ?r "Japanese 1-byte Roman character set") | |
| 248 (japanese-jisx0208-1978 ?j "Japanese 2-byte character set (old)") | |
| 249 (japanese-jisx0208 ?j "Japanese 2-byte character set") | |
| 250 (japanese-jisx0212 ?j) | |
| 251 (chinese-gb2312 ?c "Chinese GB (China, PRC) 2-byte character set") | |
| 252 (chinese-cns11643-1 ?t "Chinese Taiwan (CNS or Big5) 2-byte character set") | |
| 253 (chinese-cns11643-2 ?t) | |
| 254 (chinese-big5-1 ?t) | |
| 255 (chinese-big5-2 ?t) | |
| 256 (korean-ksc5601 ?h "Hangul (Korean) 2-byte character set") | |
| 257 ) | |
| 258 "List of predefined categories. | |
| 259 Each element is a list of a charset, a designator, and maybe a doc string.") | |
| 260 | |
| 261 (let (i l) | |
| 262 (define-category ?a "ASCII character set.") | |
| 263 (define-category ?l "Latin-1 through Latin-5 character set") | |
| 264 (setq i 32) | |
| 265 (while (< i 127) | |
| 266 (modify-category-entry i ?a) | |
| 267 (modify-category-entry i ?l) | |
| 268 (setq i (1+ i))) | |
| 269 (setq l predefined-category-list) | |
| 270 (while l | |
| 271 (if (and (nth 2 (car l)) | |
| 272 (not (defined-category-p (nth 2 (car l))))) | |
| 273 (define-category (nth 1 (car l)) (nth 2 (car l)))) | |
| 952 | 274 (modify-category-entry (car (car l)) (nth 1 (car l)) nil t) |
| 428 | 275 (setq l (cdr l)))) |
| 276 | |
| 277 ;;; Setting word boundary. | |
| 278 | |
| 279 (setq word-combining-categories | |
| 280 '((?l . ?l))) | |
| 281 | |
| 282 (setq word-separating-categories ; (2-byte character sets) | |
| 283 '((?A . ?K) ; Alpha numeric - Katakana | |
| 284 (?A . ?C) ; Alpha numeric - Chinese | |
| 285 (?H . ?A) ; Hiragana - Alpha numeric | |
| 286 (?H . ?K) ; Hiragana - Katakana | |
| 287 (?H . ?C) ; Hiragana - Chinese | |
| 288 (?K . ?A) ; Katakana - Alpha numeric | |
| 289 (?K . ?C) ; Katakana - Chinese | |
| 290 (?C . ?A) ; Chinese - Alpha numeric | |
| 291 (?C . ?K) ; Chinese - Katakana | |
| 292 )) | |
| 293 | |
| 294 ;;; At the present, I know Japanese and Chinese text can | |
| 295 ;;; break line at any point under a restriction of 'kinsoku'. | |
| 450 | 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. | |
| 428 | 301 (defvar word-across-newline "\\(\\cj\\|\\cc\\|\\ct\\)" |
| 302 "Regular expression of such characters which can be a word across newline.") | |
| 303 | |
| 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]") | |
| 311 | |
| 312 (defvar kanji-char "\\cj") | |
| 313 (defvar kanji-space "$B!!(B") | |
| 314 (defvar kanji-symbols "\\cS") | |
| 315 (defvar kanji-numeric "[$B#0(B-$B#9(B]") | |
| 316 (defvar kanji-English-Upper "[$B#A(B-$B#Z(B]") | |
| 317 (defvar kanji-English-Lower "[$B#a(B-$B#z(B]") | |
| 318 (defvar kanji-hiragana "\\cH") | |
| 319 (defvar kanji-katakana "\\cK") | |
| 320 (defvar kanji-Greek-Upper "[$B&!(B-$B&8(B]") | |
| 321 (defvar kanji-Greek-Lower "[$B&A(B-$B&X(B]") | |
| 322 (defvar kanji-Russian-Upper "[$B'!(B-$B'A(B]") | |
| 323 (defvar kanji-Russian-Lower "[$B'Q(B-$B'q(B]") | |
| 324 (defvar kanji-Kanji-1st-Level "[$B0!(B-$BOS(B]") | |
| 325 (defvar kanji-Kanji-2nd-Level "[$BP!(B-$Bt$(B]") | |
| 326 | |
| 327 (defvar kanji-kanji-char "\\(\\cH\\|\\cK\\|\\cC\\)") |