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