Mercurial > hg > xemacs-beta
annotate src/casetab.c @ 5482:384423af8fb5 first-gplv3 r21-5-31
Update CHANGES-beta.
| author | Stephen J. Turnbull <stephen@xemacs.org> |
|---|---|
| date | Sat, 30 Apr 2011 12:50:14 +0900 |
| parents | 308d34e9f07d |
| children |
| rev | line source |
|---|---|
| 428 | 1 /* XEmacs routines to deal with case tables. |
| 2 Copyright (C) 1987, 1992, 1993, 1994 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Sun Microsystems, Inc. | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
4 Copyright (C) 2002, 2010 Ben Wing. |
| 428 | 5 |
| 6 This file is part of XEmacs. | |
| 7 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5170
diff
changeset
|
8 XEmacs is free software: you can redistribute it and/or modify it |
| 428 | 9 under the terms of the GNU General Public License as published by the |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5170
diff
changeset
|
10 Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5170
diff
changeset
|
11 option) any later version. |
| 428 | 12 |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5170
diff
changeset
|
19 along with XEmacs. If not, see <http://www.gnu.org/licenses/>. */ |
| 428 | 20 |
| 771 | 21 /* Synched up with: FSF 19.28. Between FSF 19.28 and 19.30, casetab.c |
| 428 | 22 was rewritten to use junky FSF char tables. Meanwhile I rewrote it |
| 771 | 23 to use more logical char tables. --ben */ |
| 428 | 24 |
| 826 | 25 /* Written by Howard Gayle. */ |
| 428 | 26 |
| 27 /* Modified for Mule by Ben Wing. */ | |
| 28 | |
| 826 | 29 /* The four tables in a case table are downcase, upcase, canon, and eqv. |
| 30 Each is a char-table. Their workings are rather non-obvious. | |
| 31 | |
| 32 (1) `downcase' is the only obvious table: Map a character to its | |
| 33 lowercase equivalent. | |
| 771 | 34 |
| 826 | 35 (2) `upcase' does *NOT* map a character to its uppercase equivalent, |
| 36 despite its name. Rather, it maps lowercase characters to their | |
| 37 uppercase equivalent, and uppercase characters to *ANYTHING BUT* their | |
| 38 uppercase equivalent (currently, their lowercase equivalent), and | |
| 39 characters without case to themselves. It is used to determine if a | |
| 40 character "has no case" (no uppercase or lowercase mapping). #### This | |
| 41 is way bogus. Just use the obvious implementation of uppercase mapping | |
| 42 and of NOCASE_P. | |
| 446 | 43 |
| 826 | 44 (3) `canon' maps each character to a "canonical" lowercase, such that if |
| 45 two different uppercase characters map to the same lowercase character, | |
| 46 or vice versa, both characters will have the same entry in the canon | |
| 47 table. | |
| 446 | 48 |
|
4407
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
49 (4) `eqv' lists the "equivalence classes" defined by `canon'. Imagine |
| 826 | 50 that all characters are divided into groups having the same `canon' |
|
4407
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
51 entry; these groups are called "equivalence classes" and `eqv' lists them |
|
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
52 by linking the characters in each equivalence class together in a |
|
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
53 circular list. That is, to find out all all the members of a given char's |
| 4890 | 54 equivalence class, you need something like the following code: |
| 826 | 55 |
|
4407
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
56 (let* ((char ?i) |
|
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
57 (original-char char) |
|
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
58 (standard-case-eqv (case-table-eqv (standard-case-table)))) |
|
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
59 (loop |
|
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
60 with res = (list char) |
|
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
61 until (eq (setq char (get-char-table char standard-case-eqv)) |
|
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
62 original-char) |
|
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
63 do (push char res) |
|
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
64 finally return res)) |
|
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
65 |
|
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
66 (Where #'case-table-eqv doesn't yet exist, and probably never will, given |
|
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
67 that the C code needs to keep it in a consistent state so Lisp can't mess |
|
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
68 around with it.) |
|
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
69 |
|
4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
70 `canon' is used when doing case-insensitive comparisons. `eqv' is |
| 826 | 71 used in the Boyer-Moore search code. |
| 72 */ | |
| 428 | 73 |
| 74 #include <config.h> | |
| 75 #include "lisp.h" | |
| 76 #include "buffer.h" | |
| 77 #include "opaque.h" | |
| 446 | 78 #include "chartab.h" |
| 79 #include "casetab.h" | |
| 428 | 80 |
| 446 | 81 Lisp_Object Qcase_tablep, Qdowncase, Qupcase; |
| 82 Lisp_Object Vstandard_case_table; | |
| 428 | 83 |
| 446 | 84 Lisp_Object case_table_char (Lisp_Object ch, Lisp_Object table); |
| 428 | 85 |
| 826 | 86 #define STRING256_P(obj) ((STRINGP (obj) && string_char_length (obj) == 256)) |
| 446 | 87 |
| 88 static Lisp_Object | |
| 89 mark_case_table (Lisp_Object obj) | |
| 90 { | |
| 91 Lisp_Case_Table *ct = XCASE_TABLE (obj); | |
| 92 | |
| 93 mark_object (CASE_TABLE_DOWNCASE (ct)); | |
| 94 mark_object (CASE_TABLE_UPCASE (ct)); | |
| 95 mark_object (CASE_TABLE_CANON (ct)); | |
| 96 mark_object (CASE_TABLE_EQV (ct)); | |
| 97 return Qnil; | |
| 98 } | |
| 99 | |
| 100 static void | |
| 2286 | 101 print_case_table (Lisp_Object obj, Lisp_Object printcharfun, |
| 102 int UNUSED (escapeflag)) | |
| 446 | 103 { |
| 104 Lisp_Case_Table *ct = XCASE_TABLE (obj); | |
| 105 if (print_readably) | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
106 printing_unreadable_lisp_object (obj, 0); |
| 826 | 107 write_fmt_string_lisp |
| 108 (printcharfun, "#<case-table downcase=%s upcase=%s canon=%s eqv=%s ", 4, | |
| 109 CASE_TABLE_DOWNCASE (ct), CASE_TABLE_UPCASE (ct), | |
| 110 CASE_TABLE_CANON (ct), CASE_TABLE_EQV (ct)); | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
111 write_fmt_string (printcharfun, "0x%x>", LISP_OBJECT_UID (obj)); |
| 446 | 112 } |
| 113 | |
| 1204 | 114 static const struct memory_description case_table_description [] = { |
| 446 | 115 { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, downcase_table) }, |
| 116 { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, upcase_table) }, | |
| 117 { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, case_canon_table) }, | |
| 118 { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, case_eqv_table) }, | |
| 119 { XD_END } | |
| 120 }; | |
| 121 | |
| 934 | 122 |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
123 DEFINE_DUMPABLE_LISP_OBJECT ("case-table", case_table, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
124 mark_case_table, print_case_table, 0, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
125 0, 0, case_table_description, Lisp_Case_Table); |
| 446 | 126 |
| 127 static Lisp_Object | |
| 826 | 128 allocate_case_table (int init_tables) |
| 446 | 129 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
130 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (case_table); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
131 Lisp_Case_Table *ct = XCASE_TABLE (obj); |
| 446 | 132 |
| 826 | 133 if (init_tables) |
| 134 { | |
| 135 SET_CASE_TABLE_DOWNCASE (ct, MAKE_TRT_TABLE ()); | |
| 136 SET_CASE_TABLE_UPCASE (ct, MAKE_TRT_TABLE ()); | |
| 137 SET_CASE_TABLE_CANON (ct, MAKE_TRT_TABLE ()); | |
| 138 SET_CASE_TABLE_EQV (ct, MAKE_TRT_TABLE ()); | |
| 139 } | |
| 140 else | |
| 141 { | |
| 142 SET_CASE_TABLE_DOWNCASE (ct, Qnil); | |
| 143 SET_CASE_TABLE_UPCASE (ct, Qnil); | |
| 144 SET_CASE_TABLE_CANON (ct, Qnil); | |
| 145 SET_CASE_TABLE_EQV (ct, Qnil); | |
| 146 } | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
147 return obj; |
| 826 | 148 } |
| 446 | 149 |
| 826 | 150 DEFUN ("make-case-table", Fmake_case_table, 0, 0, 0, /* |
| 151 Create a new, empty case table. | |
| 152 */ | |
| 153 ()) | |
| 154 { | |
| 155 return allocate_case_table (1); | |
| 446 | 156 } |
| 428 | 157 |
| 158 DEFUN ("case-table-p", Fcase_table_p, 1, 1, 0, /* | |
| 444 | 159 Return t if OBJECT is a case table. |
| 428 | 160 See `set-case-table' for more information on these data structures. |
| 161 */ | |
| 444 | 162 (object)) |
| 428 | 163 { |
| 446 | 164 if (CASE_TABLEP (object)) |
| 165 return Qt; | |
| 166 else | |
| 167 { | |
| 168 Lisp_Object down, up, canon, eqv; | |
| 169 if (!CONSP (object)) | |
| 170 return Qnil; | |
| 171 down = XCAR (object); object = XCDR (object); | |
| 172 if (!CONSP (object)) | |
| 173 return Qnil; | |
| 174 up = XCAR (object); object = XCDR (object); | |
| 175 if (!CONSP (object)) | |
| 176 return Qnil; | |
| 177 canon = XCAR (object); object = XCDR (object); | |
| 178 if (!CONSP (object)) | |
| 179 return Qnil; | |
| 180 eqv = XCAR (object); | |
| 428 | 181 |
| 446 | 182 return ((STRING256_P (down) |
| 183 && (NILP (up) || STRING256_P (up)) | |
| 184 && ((NILP (canon) && NILP (eqv)) | |
| 185 || STRING256_P (canon)) | |
| 186 && (NILP (eqv) || STRING256_P (eqv))) | |
| 187 ? Qt : Qnil); | |
| 188 | |
| 189 } | |
| 428 | 190 } |
| 191 | |
| 192 static Lisp_Object | |
| 444 | 193 check_case_table (Lisp_Object object) |
| 428 | 194 { |
| 446 | 195 /* This function can GC */ |
| 444 | 196 while (NILP (Fcase_table_p (object))) |
| 197 object = wrong_type_argument (Qcase_tablep, object); | |
| 198 return object; | |
| 428 | 199 } |
| 200 | |
| 446 | 201 Lisp_Object |
| 202 case_table_char (Lisp_Object ch, Lisp_Object table) | |
| 203 { | |
| 204 Lisp_Object ct_char; | |
| 826 | 205 ct_char = get_char_table (XCHAR (ch), table); |
| 446 | 206 if (NILP (ct_char)) |
| 207 return ch; | |
| 208 else | |
| 209 return ct_char; | |
| 210 } | |
| 211 | |
| 212 DEFUN ("get-case-table", Fget_case_table, 3, 3, 0, /* | |
| 213 Return CHAR-CASE version of CHARACTER in CASE-TABLE. | |
| 214 | |
| 826 | 215 CHAR-CASE is either `downcase' or `upcase'. |
| 446 | 216 */ |
| 217 (char_case, character, case_table)) | |
| 218 { | |
| 219 CHECK_CHAR (character); | |
| 220 CHECK_CASE_TABLE (case_table); | |
| 221 if (EQ (char_case, Qdowncase)) | |
| 222 return case_table_char (character, XCASE_TABLE_DOWNCASE (case_table)); | |
| 223 else if (EQ (char_case, Qupcase)) | |
| 224 return case_table_char (character, XCASE_TABLE_UPCASE (case_table)); | |
| 225 else | |
| 563 | 226 invalid_constant ("Char case must be downcase or upcase", char_case); |
| 446 | 227 |
| 228 return Qnil; /* Not reached. */ | |
| 229 } | |
| 230 | |
| 231 DEFUN ("put-case-table", Fput_case_table, 4, 4, 0, /* | |
| 232 Set CHAR-CASE version of CHARACTER to be VALUE in CASE-TABLE. | |
| 233 | |
| 826 | 234 CHAR-CASE is either `downcase' or `upcase'. |
| 446 | 235 See also `put-case-table-pair'. |
| 236 */ | |
| 237 (char_case, character, value, case_table)) | |
| 238 { | |
| 239 CHECK_CHAR (character); | |
| 240 CHECK_CHAR (value); | |
| 241 | |
| 242 if (EQ (char_case, Qdowncase)) | |
| 243 { | |
| 244 Fput_char_table (character, value, XCASE_TABLE_DOWNCASE (case_table)); | |
| 826 | 245 /* This one is not at all intuitive. See comment at top of file. */ |
| 446 | 246 Fput_char_table (character, value, XCASE_TABLE_UPCASE (case_table)); |
| 247 } | |
| 248 else if (EQ (char_case, Qupcase)) | |
| 249 { | |
| 250 Fput_char_table (character, value, XCASE_TABLE_UPCASE (case_table)); | |
| 826 | 251 Fput_char_table (character, character, |
| 252 XCASE_TABLE_DOWNCASE (case_table)); | |
| 446 | 253 } |
| 254 else | |
| 826 | 255 invalid_constant ("CHAR-CASE must be downcase or upcase", char_case); |
| 446 | 256 |
| 826 | 257 XCASE_TABLE (case_table)->dirty = 1; |
| 446 | 258 return Qnil; |
| 259 } | |
| 260 | |
| 261 DEFUN ("put-case-table-pair", Fput_case_table_pair, 3, 3, 0, /* | |
| 262 Make UC and LC a pair of inter-case-converting letters in CASE-TABLE. | |
| 263 UC is an uppercase character and LC is a downcase character. | |
| 264 */ | |
| 265 (uc, lc, case_table)) | |
| 266 { | |
| 267 CHECK_CHAR (uc); | |
| 268 CHECK_CHAR (lc); | |
| 269 CHECK_CASE_TABLE (case_table); | |
| 270 | |
| 271 Fput_char_table (lc, lc, XCASE_TABLE_DOWNCASE (case_table)); | |
| 272 Fput_char_table (uc, lc, XCASE_TABLE_UPCASE (case_table)); | |
| 273 Fput_char_table (uc, lc, XCASE_TABLE_DOWNCASE (case_table)); | |
| 274 Fput_char_table (lc, uc, XCASE_TABLE_UPCASE (case_table)); | |
| 275 | |
| 826 | 276 XCASE_TABLE (case_table)->dirty = 1; |
| 446 | 277 return Qnil; |
| 278 } | |
| 279 | |
| 280 DEFUN ("copy-case-table", Fcopy_case_table, 1, 1, 0, /* | |
| 281 Return a new case table which is a copy of CASE-TABLE | |
| 282 */ | |
| 283 (case_table)) | |
| 284 { | |
| 285 Lisp_Object new_obj; | |
| 286 CHECK_CASE_TABLE (case_table); | |
| 287 | |
| 826 | 288 new_obj = allocate_case_table (0); |
| 446 | 289 XSET_CASE_TABLE_DOWNCASE |
| 290 (new_obj, Fcopy_char_table (XCASE_TABLE_DOWNCASE (case_table))); | |
| 291 XSET_CASE_TABLE_UPCASE | |
| 292 (new_obj, Fcopy_char_table (XCASE_TABLE_UPCASE (case_table))); | |
| 293 XSET_CASE_TABLE_CANON | |
| 294 (new_obj, Fcopy_char_table (XCASE_TABLE_CANON (case_table))); | |
| 295 XSET_CASE_TABLE_EQV | |
| 296 (new_obj, Fcopy_char_table (XCASE_TABLE_EQV (case_table))); | |
| 297 return new_obj; | |
| 298 } | |
| 299 | |
| 826 | 300 static int |
| 301 compute_canon_mapper (struct chartab_range *range, | |
| 2286 | 302 Lisp_Object UNUSED (table), Lisp_Object val, void *arg) |
| 826 | 303 { |
| 5013 | 304 Lisp_Object casetab = GET_LISP_FROM_VOID (arg); |
| 826 | 305 if (range->type == CHARTAB_RANGE_CHAR) |
| 306 SET_TRT_TABLE_OF (XCASE_TABLE_CANON (casetab), range->ch, | |
| 307 TRT_TABLE_OF (XCASE_TABLE_DOWNCASE (casetab), | |
| 308 TRT_TABLE_OF (XCASE_TABLE_UPCASE (casetab), | |
| 309 XCHAR (val)))); | |
| 310 | |
| 311 return 0; | |
| 312 } | |
| 313 | |
| 314 static int | |
| 315 initialize_identity_mapper (struct chartab_range *range, | |
| 2286 | 316 Lisp_Object UNUSED (table), |
| 317 Lisp_Object UNUSED (val), void *arg) | |
| 826 | 318 { |
| 5013 | 319 Lisp_Object trt = GET_LISP_FROM_VOID (arg); |
| 826 | 320 if (range->type == CHARTAB_RANGE_CHAR) |
| 321 SET_TRT_TABLE_OF (trt, range->ch, range->ch); | |
| 322 | |
| 323 return 0; | |
| 324 } | |
| 325 | |
| 326 static int | |
| 327 compute_up_or_eqv_mapper (struct chartab_range *range, | |
| 2286 | 328 Lisp_Object UNUSED (table), |
| 329 Lisp_Object val, void *arg) | |
| 826 | 330 { |
| 5013 | 331 Lisp_Object inverse = GET_LISP_FROM_VOID (arg); |
| 867 | 332 Ichar toch = XCHAR (val); |
| 826 | 333 |
| 334 if (range->type == CHARTAB_RANGE_CHAR && range->ch != toch) | |
| 335 { | |
| 867 | 336 Ichar c = TRT_TABLE_OF (inverse, toch); |
| 826 | 337 SET_TRT_TABLE_OF (inverse, toch, range->ch); |
| 338 SET_TRT_TABLE_OF (inverse, range->ch, c); | |
| 339 } | |
| 340 | |
| 341 return 0; | |
| 342 } | |
| 343 | |
| 344 /* Recomputing the canonical and equivalency tables from scratch is a | |
| 345 lengthy process, and doing them incrementally is extremely difficult or | |
| 346 perhaps impossible -- and certainly not worth it. To avoid lots of | |
| 347 excessive recomputation when lots of stuff is incrementally added, we | |
| 348 just store a dirty flag and then recompute when a value from the canon | |
| 349 or eqv tables is actually needed. */ | |
| 350 | |
| 351 void | |
| 352 recompute_case_table (Lisp_Object casetab) | |
| 353 { | |
| 354 struct chartab_range range; | |
| 355 | |
| 356 range.type = CHARTAB_RANGE_ALL; | |
| 357 /* Turn off dirty flag first so we don't get infinite recursion when | |
| 358 retrieving the values below! */ | |
| 359 XCASE_TABLE (casetab)->dirty = 0; | |
| 360 map_char_table (XCASE_TABLE_DOWNCASE (casetab), &range, | |
| 5013 | 361 compute_canon_mapper, STORE_LISP_IN_VOID (casetab)); |
| 826 | 362 map_char_table (XCASE_TABLE_CANON (casetab), &range, |
| 363 initialize_identity_mapper, | |
| 5013 | 364 STORE_LISP_IN_VOID (XCASE_TABLE_EQV (casetab))); |
| 826 | 365 map_char_table (XCASE_TABLE_CANON (casetab), &range, |
| 366 compute_up_or_eqv_mapper, | |
| 5013 | 367 STORE_LISP_IN_VOID (XCASE_TABLE_EQV (casetab))); |
| 826 | 368 } |
| 369 | |
| 428 | 370 DEFUN ("current-case-table", Fcurrent_case_table, 0, 1, 0, /* |
| 371 Return the case table of BUFFER, which defaults to the current buffer. | |
| 372 */ | |
| 373 (buffer)) | |
| 374 { | |
| 375 struct buffer *buf = decode_buffer (buffer, 0); | |
| 376 | |
| 446 | 377 return buf->case_table; |
| 428 | 378 } |
| 379 | |
| 380 DEFUN ("standard-case-table", Fstandard_case_table, 0, 0, 0, /* | |
| 381 Return the standard case table. | |
| 382 This is the one used for new buffers. | |
| 383 */ | |
| 384 ()) | |
| 385 { | |
| 446 | 386 return Vstandard_case_table; |
| 428 | 387 } |
| 388 | |
| 826 | 389 static void |
| 390 convert_old_style_syntax_string (Lisp_Object table, Lisp_Object string) | |
| 391 { | |
| 867 | 392 Ichar i; |
| 826 | 393 |
| 394 for (i = 0; i < 256; i++) | |
| 867 | 395 SET_TRT_TABLE_OF (table, i, string_ichar (string, i)); |
| 826 | 396 } |
| 397 | |
| 398 static Lisp_Object | |
| 399 set_case_table (Lisp_Object table, int standard) | |
| 400 { | |
| 401 /* This function can GC */ | |
| 402 struct buffer *buf = | |
| 403 standard ? XBUFFER (Vbuffer_defaults) : current_buffer; | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4890
diff
changeset
|
404 Lisp_Object casetab; |
| 826 | 405 |
| 406 check_case_table (table); | |
| 407 | |
| 408 if (CASE_TABLEP (table)) | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4890
diff
changeset
|
409 casetab = table; |
| 826 | 410 else |
| 411 { | |
| 412 /* For backward compatibility. */ | |
| 413 Lisp_Object down, up, canon, eqv, tail = table; | |
| 414 struct chartab_range range; | |
| 415 | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4890
diff
changeset
|
416 casetab = Fmake_case_table (); |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4890
diff
changeset
|
417 |
| 826 | 418 range.type = CHARTAB_RANGE_ALL; |
| 419 | |
| 420 Freset_char_table (XCASE_TABLE_DOWNCASE (casetab)); | |
| 421 Freset_char_table (XCASE_TABLE_UPCASE (casetab)); | |
| 422 Freset_char_table (XCASE_TABLE_CANON (casetab)); | |
| 423 Freset_char_table (XCASE_TABLE_EQV (casetab)); | |
| 424 | |
| 425 down = XCAR (tail); tail = XCDR (tail); | |
| 426 up = XCAR (tail); tail = XCDR (tail); | |
| 427 canon = XCAR (tail); tail = XCDR (tail); | |
| 428 eqv = XCAR (tail); | |
| 429 | |
| 430 convert_old_style_syntax_string (XCASE_TABLE_DOWNCASE (casetab), down); | |
| 431 | |
| 432 if (NILP (up)) | |
| 433 { | |
| 434 map_char_table (XCASE_TABLE_DOWNCASE (casetab), &range, | |
| 435 initialize_identity_mapper, | |
| 5013 | 436 STORE_LISP_IN_VOID (XCASE_TABLE_UPCASE (casetab))); |
| 826 | 437 map_char_table (XCASE_TABLE_DOWNCASE (casetab), &range, |
| 438 compute_up_or_eqv_mapper, | |
| 5013 | 439 STORE_LISP_IN_VOID (XCASE_TABLE_UPCASE (casetab))); |
| 826 | 440 } |
| 441 else | |
| 442 convert_old_style_syntax_string (XCASE_TABLE_UPCASE (casetab), up); | |
| 443 | |
| 444 if (NILP (canon)) | |
| 445 map_char_table (XCASE_TABLE_DOWNCASE (casetab), &range, | |
| 5013 | 446 compute_canon_mapper, STORE_LISP_IN_VOID (casetab)); |
| 826 | 447 else |
| 448 convert_old_style_syntax_string (XCASE_TABLE_CANON (casetab), canon); | |
| 449 | |
| 450 if (NILP (eqv)) | |
| 451 { | |
| 452 map_char_table (XCASE_TABLE_CANON (casetab), &range, | |
| 453 initialize_identity_mapper, | |
| 5013 | 454 STORE_LISP_IN_VOID (XCASE_TABLE_EQV (casetab))); |
| 826 | 455 map_char_table (XCASE_TABLE_CANON (casetab), &range, |
| 456 compute_up_or_eqv_mapper, | |
| 5013 | 457 STORE_LISP_IN_VOID (XCASE_TABLE_EQV (casetab))); |
| 826 | 458 } |
| 459 else | |
| 460 convert_old_style_syntax_string (XCASE_TABLE_CANON (casetab), eqv); | |
| 461 } | |
| 462 | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4890
diff
changeset
|
463 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4890
diff
changeset
|
464 if (standard) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4890
diff
changeset
|
465 Vstandard_case_table = casetab; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4890
diff
changeset
|
466 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4890
diff
changeset
|
467 buf->case_table = casetab; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4890
diff
changeset
|
468 |
| 826 | 469 return buf->case_table; |
| 470 } | |
| 428 | 471 |
| 472 DEFUN ("set-case-table", Fset_case_table, 1, 1, 0, /* | |
| 444 | 473 Select CASE-TABLE as the new case table for the current buffer. |
| 446 | 474 A case table is a case-table object or list |
| 475 (DOWNCASE UPCASE CANONICALIZE EQUIVALENCES) | |
| 428 | 476 where each element is either nil or a string of length 256. |
| 446 | 477 The latter is provided for backward-compatibility. |
| 428 | 478 DOWNCASE maps each character to its lower-case equivalent. |
| 479 UPCASE maps each character to its upper-case equivalent; | |
| 480 if lower and upper case characters are in 1-1 correspondence, | |
| 481 you may use nil and the upcase table will be deduced from DOWNCASE. | |
| 482 CANONICALIZE maps each character to a canonical equivalent; | |
| 483 any two characters that are related by case-conversion have the same | |
| 484 canonical equivalent character; it may be nil, in which case it is | |
| 485 deduced from DOWNCASE and UPCASE. | |
| 486 EQUIVALENCES is a map that cyclicly permutes each equivalence class | |
| 487 (of characters with the same canonical equivalent); it may be nil, | |
| 488 in which case it is deduced from CANONICALIZE. | |
| 489 | |
| 446 | 490 See also `get-case-table', `put-case-table' and `put-case-table-pair'. |
| 428 | 491 */ |
| 444 | 492 (case_table)) |
| 428 | 493 { |
| 446 | 494 /* This function can GC */ |
| 444 | 495 return set_case_table (case_table, 0); |
| 428 | 496 } |
| 497 | |
| 498 DEFUN ("set-standard-case-table", Fset_standard_case_table, 1, 1, 0, /* | |
| 444 | 499 Select CASE-TABLE as the new standard case table for new buffers. |
| 428 | 500 See `set-case-table' for more info on case tables. |
| 501 */ | |
| 444 | 502 (case_table)) |
| 428 | 503 { |
| 446 | 504 /* This function can GC */ |
| 444 | 505 return set_case_table (case_table, 1); |
| 428 | 506 } |
| 507 | |
| 508 | |
|
5170
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
509 #ifdef MEMORY_USAGE_STATS |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
510 |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
511 struct case_table_stats |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
512 { |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
513 struct usage_stats u; |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
514 /* Ancillary Lisp */ |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
515 Bytecount downcase, upcase, case_canon, case_eqv; |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
516 }; |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
517 |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
518 static void |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
519 case_table_memory_usage (Lisp_Object casetab, |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
520 struct generic_usage_stats *gustats) |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
521 { |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
522 struct case_table_stats *stats = (struct case_table_stats *) gustats; |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
523 |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
524 stats->downcase = lisp_object_memory_usage (XCASE_TABLE_DOWNCASE (casetab)); |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
525 stats->upcase = lisp_object_memory_usage (XCASE_TABLE_UPCASE (casetab)); |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
526 stats->case_canon = lisp_object_memory_usage (XCASE_TABLE_CANON (casetab)); |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
527 stats->case_eqv = lisp_object_memory_usage (XCASE_TABLE_EQV (casetab)); |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
528 } |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
529 |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
530 #endif /* MEMORY_USAGE_STATS */ |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
531 |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
532 |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
533 void |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
534 casetab_objects_create (void) |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
535 { |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
536 #ifdef MEMORY_USAGE_STATS |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
537 OBJECT_HAS_METHOD (case_table, memory_usage); |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
538 #endif |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
539 } |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
540 |
| 428 | 541 void |
| 542 syms_of_casetab (void) | |
| 543 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
544 INIT_LISP_OBJECT (case_table); |
| 446 | 545 |
| 563 | 546 DEFSYMBOL_MULTIWORD_PREDICATE (Qcase_tablep); |
| 547 DEFSYMBOL (Qdowncase); | |
| 548 DEFSYMBOL (Qupcase); | |
| 428 | 549 |
| 826 | 550 DEFSUBR (Fmake_case_table); |
| 428 | 551 DEFSUBR (Fcase_table_p); |
| 446 | 552 DEFSUBR (Fget_case_table); |
| 553 DEFSUBR (Fput_case_table); | |
| 554 DEFSUBR (Fput_case_table_pair); | |
| 428 | 555 DEFSUBR (Fcurrent_case_table); |
| 556 DEFSUBR (Fstandard_case_table); | |
| 446 | 557 DEFSUBR (Fcopy_case_table); |
| 428 | 558 DEFSUBR (Fset_case_table); |
| 559 DEFSUBR (Fset_standard_case_table); | |
| 560 } | |
| 561 | |
| 562 void | |
|
5170
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
563 vars_of_casetab (void) |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
564 { |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
565 #ifdef MEMORY_USAGE_STATS |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
566 OBJECT_HAS_PROPERTY (case_table, memusage_stats_list, |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
567 list5 (Qt, |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
568 intern ("downcase"), |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
569 intern ("upcase"), |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
570 intern ("case-canon"), |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
571 intern ("case-eqv"))); |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
572 #endif /* MEMORY_USAGE_STATS */ |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
573 } |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
574 |
|
5ddbab03b0e6
various fixes to memory-usage stats
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
575 void |
| 428 | 576 complex_vars_of_casetab (void) |
| 577 { | |
| 867 | 578 REGISTER Ichar i; |
| 428 | 579 |
| 446 | 580 staticpro (&Vstandard_case_table); |
| 428 | 581 |
| 826 | 582 Vstandard_case_table = allocate_case_table (1); |
| 428 | 583 |
| 584 for (i = 0; i < 256; i++) | |
| 585 { | |
| 586 unsigned char lowered = tolower (i); | |
| 587 | |
| 826 | 588 SET_TRT_TABLE_OF (XCASE_TABLE_DOWNCASE (Vstandard_case_table), i, |
| 589 lowered); | |
| 428 | 590 } |
| 591 | |
| 592 for (i = 0; i < 256; i++) | |
| 593 { | |
| 594 unsigned char flipped = (isupper (i) ? tolower (i) | |
| 595 : (islower (i) ? toupper (i) : i)); | |
| 596 | |
| 826 | 597 SET_TRT_TABLE_OF (XCASE_TABLE_UPCASE (Vstandard_case_table), i, |
| 598 flipped); | |
| 428 | 599 } |
| 826 | 600 |
| 601 recompute_case_table (Vstandard_case_table); | |
| 428 | 602 } |