Mercurial > hg > xemacs-beta
annotate src/casetab.c @ 5117:3742ea8250b5 ben-lisp-object ben-lisp-object-final-ws-year-2005
Checking in final CVS version of workspace 'ben-lisp-object'
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Sat, 26 Dec 2009 00:20:27 -0600 |
| parents | 1e7cc382eb16 |
| children | e0db3c197671 |
| 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 |
| 826 | 51 (4) `equiv' lists the "equivalence classes" defined by `canon'. Imagine |
| 52 that all characters are divided into groups having the same `canon' | |
| 53 entry; these groups are called "equivalence classes" and `equiv' lists | |
| 54 them by linking the characters in each equivalence class together in a | |
| 55 circular list. | |
| 56 | |
| 57 `canon' is used when doing case-insensitive comparisons. `equiv' is | |
| 58 used in the Boyer-Moore search code. | |
| 59 */ | |
| 428 | 60 |
| 61 #include <config.h> | |
| 62 #include "lisp.h" | |
| 63 #include "buffer.h" | |
| 64 #include "opaque.h" | |
| 446 | 65 #include "chartab.h" |
| 66 #include "casetab.h" | |
| 428 | 67 |
| 446 | 68 Lisp_Object Qcase_tablep, Qdowncase, Qupcase; |
| 69 Lisp_Object Vstandard_case_table; | |
| 428 | 70 |
| 446 | 71 Lisp_Object case_table_char (Lisp_Object ch, Lisp_Object table); |
| 428 | 72 |
| 826 | 73 #define STRING256_P(obj) ((STRINGP (obj) && string_char_length (obj) == 256)) |
| 446 | 74 |
| 75 static Lisp_Object | |
| 76 mark_case_table (Lisp_Object obj) | |
| 77 { | |
| 78 Lisp_Case_Table *ct = XCASE_TABLE (obj); | |
| 79 | |
| 80 mark_object (CASE_TABLE_DOWNCASE (ct)); | |
| 81 mark_object (CASE_TABLE_UPCASE (ct)); | |
| 82 mark_object (CASE_TABLE_CANON (ct)); | |
| 83 mark_object (CASE_TABLE_EQV (ct)); | |
| 84 return Qnil; | |
| 85 } | |
| 86 | |
| 87 static void | |
| 2286 | 88 print_case_table (Lisp_Object obj, Lisp_Object printcharfun, |
| 89 int UNUSED (escapeflag)) | |
| 446 | 90 { |
| 91 Lisp_Case_Table *ct = XCASE_TABLE (obj); | |
| 92 if (print_readably) | |
| 826 | 93 printing_unreadable_object ("#<case-table 0x%x>", ct->header.uid); |
| 94 write_fmt_string_lisp | |
| 95 (printcharfun, "#<case-table downcase=%s upcase=%s canon=%s eqv=%s ", 4, | |
| 96 CASE_TABLE_DOWNCASE (ct), CASE_TABLE_UPCASE (ct), | |
| 97 CASE_TABLE_CANON (ct), CASE_TABLE_EQV (ct)); | |
| 98 write_fmt_string (printcharfun, "0x%x>", ct->header.uid); | |
| 446 | 99 } |
| 100 | |
| 1204 | 101 static const struct memory_description case_table_description [] = { |
| 446 | 102 { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, downcase_table) }, |
| 103 { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, upcase_table) }, | |
| 104 { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, case_canon_table) }, | |
| 105 { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, case_eqv_table) }, | |
| 106 { XD_END } | |
| 107 }; | |
| 108 | |
| 934 | 109 |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
110 DEFINE_LISP_OBJECT("case-table", case_table, |
| 934 | 111 mark_case_table, print_case_table, 0, |
| 112 0, 0, case_table_description, Lisp_Case_Table); | |
| 446 | 113 |
| 114 static Lisp_Object | |
| 826 | 115 allocate_case_table (int init_tables) |
| 446 | 116 { |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
117 Lisp_Object obj = ALLOC_LISP_OBJECT (case_table); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
118 Lisp_Case_Table *ct = XCASE_TABLE (obj); |
| 446 | 119 |
| 826 | 120 if (init_tables) |
| 121 { | |
| 122 SET_CASE_TABLE_DOWNCASE (ct, MAKE_TRT_TABLE ()); | |
| 123 SET_CASE_TABLE_UPCASE (ct, MAKE_TRT_TABLE ()); | |
| 124 SET_CASE_TABLE_CANON (ct, MAKE_TRT_TABLE ()); | |
| 125 SET_CASE_TABLE_EQV (ct, MAKE_TRT_TABLE ()); | |
| 126 } | |
| 127 else | |
| 128 { | |
| 129 SET_CASE_TABLE_DOWNCASE (ct, Qnil); | |
| 130 SET_CASE_TABLE_UPCASE (ct, Qnil); | |
| 131 SET_CASE_TABLE_CANON (ct, Qnil); | |
| 132 SET_CASE_TABLE_EQV (ct, Qnil); | |
| 133 } | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
134 return obj; |
| 826 | 135 } |
| 446 | 136 |
| 826 | 137 DEFUN ("make-case-table", Fmake_case_table, 0, 0, 0, /* |
| 138 Create a new, empty case table. | |
| 139 */ | |
| 140 ()) | |
| 141 { | |
| 142 return allocate_case_table (1); | |
| 446 | 143 } |
| 428 | 144 |
| 145 DEFUN ("case-table-p", Fcase_table_p, 1, 1, 0, /* | |
| 444 | 146 Return t if OBJECT is a case table. |
| 428 | 147 See `set-case-table' for more information on these data structures. |
| 148 */ | |
| 444 | 149 (object)) |
| 428 | 150 { |
| 446 | 151 if (CASE_TABLEP (object)) |
| 152 return Qt; | |
| 153 else | |
| 154 { | |
| 155 Lisp_Object down, up, canon, eqv; | |
| 156 if (!CONSP (object)) | |
| 157 return Qnil; | |
| 158 down = XCAR (object); object = XCDR (object); | |
| 159 if (!CONSP (object)) | |
| 160 return Qnil; | |
| 161 up = XCAR (object); object = XCDR (object); | |
| 162 if (!CONSP (object)) | |
| 163 return Qnil; | |
| 164 canon = XCAR (object); object = XCDR (object); | |
| 165 if (!CONSP (object)) | |
| 166 return Qnil; | |
| 167 eqv = XCAR (object); | |
| 428 | 168 |
| 446 | 169 return ((STRING256_P (down) |
| 170 && (NILP (up) || STRING256_P (up)) | |
| 171 && ((NILP (canon) && NILP (eqv)) | |
| 172 || STRING256_P (canon)) | |
| 173 && (NILP (eqv) || STRING256_P (eqv))) | |
| 174 ? Qt : Qnil); | |
| 175 | |
| 176 } | |
| 428 | 177 } |
| 178 | |
| 179 static Lisp_Object | |
| 444 | 180 check_case_table (Lisp_Object object) |
| 428 | 181 { |
| 446 | 182 /* This function can GC */ |
| 444 | 183 while (NILP (Fcase_table_p (object))) |
| 184 object = wrong_type_argument (Qcase_tablep, object); | |
| 185 return object; | |
| 428 | 186 } |
| 187 | |
| 446 | 188 Lisp_Object |
| 189 case_table_char (Lisp_Object ch, Lisp_Object table) | |
| 190 { | |
| 191 Lisp_Object ct_char; | |
| 826 | 192 ct_char = get_char_table (XCHAR (ch), table); |
| 446 | 193 if (NILP (ct_char)) |
| 194 return ch; | |
| 195 else | |
| 196 return ct_char; | |
| 197 } | |
| 198 | |
| 199 DEFUN ("get-case-table", Fget_case_table, 3, 3, 0, /* | |
| 200 Return CHAR-CASE version of CHARACTER in CASE-TABLE. | |
| 201 | |
| 826 | 202 CHAR-CASE is either `downcase' or `upcase'. |
| 446 | 203 */ |
| 204 (char_case, character, case_table)) | |
| 205 { | |
| 206 CHECK_CHAR (character); | |
| 207 CHECK_CASE_TABLE (case_table); | |
| 208 if (EQ (char_case, Qdowncase)) | |
| 209 return case_table_char (character, XCASE_TABLE_DOWNCASE (case_table)); | |
| 210 else if (EQ (char_case, Qupcase)) | |
| 211 return case_table_char (character, XCASE_TABLE_UPCASE (case_table)); | |
| 212 else | |
| 563 | 213 invalid_constant ("Char case must be downcase or upcase", char_case); |
| 446 | 214 |
| 215 return Qnil; /* Not reached. */ | |
| 216 } | |
| 217 | |
| 218 DEFUN ("put-case-table", Fput_case_table, 4, 4, 0, /* | |
| 219 Set CHAR-CASE version of CHARACTER to be VALUE in CASE-TABLE. | |
| 220 | |
| 826 | 221 CHAR-CASE is either `downcase' or `upcase'. |
| 446 | 222 See also `put-case-table-pair'. |
| 223 */ | |
| 224 (char_case, character, value, case_table)) | |
| 225 { | |
| 226 CHECK_CHAR (character); | |
| 227 CHECK_CHAR (value); | |
| 228 | |
| 229 if (EQ (char_case, Qdowncase)) | |
| 230 { | |
| 231 Fput_char_table (character, value, XCASE_TABLE_DOWNCASE (case_table)); | |
| 826 | 232 /* This one is not at all intuitive. See comment at top of file. */ |
| 446 | 233 Fput_char_table (character, value, XCASE_TABLE_UPCASE (case_table)); |
| 234 } | |
| 235 else if (EQ (char_case, Qupcase)) | |
| 236 { | |
| 237 Fput_char_table (character, value, XCASE_TABLE_UPCASE (case_table)); | |
| 826 | 238 Fput_char_table (character, character, |
| 239 XCASE_TABLE_DOWNCASE (case_table)); | |
| 446 | 240 } |
| 241 else | |
| 826 | 242 invalid_constant ("CHAR-CASE must be downcase or upcase", char_case); |
| 446 | 243 |
| 826 | 244 XCASE_TABLE (case_table)->dirty = 1; |
| 446 | 245 return Qnil; |
| 246 } | |
| 247 | |
| 248 DEFUN ("put-case-table-pair", Fput_case_table_pair, 3, 3, 0, /* | |
| 249 Make UC and LC a pair of inter-case-converting letters in CASE-TABLE. | |
| 250 UC is an uppercase character and LC is a downcase character. | |
| 251 */ | |
| 252 (uc, lc, case_table)) | |
| 253 { | |
| 254 CHECK_CHAR (uc); | |
| 255 CHECK_CHAR (lc); | |
| 256 CHECK_CASE_TABLE (case_table); | |
| 257 | |
| 258 Fput_char_table (lc, lc, XCASE_TABLE_DOWNCASE (case_table)); | |
| 259 Fput_char_table (uc, lc, XCASE_TABLE_UPCASE (case_table)); | |
| 260 Fput_char_table (uc, lc, XCASE_TABLE_DOWNCASE (case_table)); | |
| 261 Fput_char_table (lc, uc, XCASE_TABLE_UPCASE (case_table)); | |
| 262 | |
| 826 | 263 XCASE_TABLE (case_table)->dirty = 1; |
| 446 | 264 return Qnil; |
| 265 } | |
| 266 | |
| 267 DEFUN ("copy-case-table", Fcopy_case_table, 1, 1, 0, /* | |
| 268 Return a new case table which is a copy of CASE-TABLE | |
| 269 */ | |
| 270 (case_table)) | |
| 271 { | |
| 272 Lisp_Object new_obj; | |
| 273 CHECK_CASE_TABLE (case_table); | |
| 274 | |
| 826 | 275 new_obj = allocate_case_table (0); |
| 446 | 276 XSET_CASE_TABLE_DOWNCASE |
| 277 (new_obj, Fcopy_char_table (XCASE_TABLE_DOWNCASE (case_table))); | |
| 278 XSET_CASE_TABLE_UPCASE | |
| 279 (new_obj, Fcopy_char_table (XCASE_TABLE_UPCASE (case_table))); | |
| 280 XSET_CASE_TABLE_CANON | |
| 281 (new_obj, Fcopy_char_table (XCASE_TABLE_CANON (case_table))); | |
| 282 XSET_CASE_TABLE_EQV | |
| 283 (new_obj, Fcopy_char_table (XCASE_TABLE_EQV (case_table))); | |
| 284 return new_obj; | |
| 285 } | |
| 286 | |
| 826 | 287 static int |
| 288 compute_canon_mapper (struct chartab_range *range, | |
| 2286 | 289 Lisp_Object UNUSED (table), Lisp_Object val, void *arg) |
| 826 | 290 { |
| 291 Lisp_Object casetab = VOID_TO_LISP (arg); | |
| 292 if (range->type == CHARTAB_RANGE_CHAR) | |
| 293 SET_TRT_TABLE_OF (XCASE_TABLE_CANON (casetab), range->ch, | |
| 294 TRT_TABLE_OF (XCASE_TABLE_DOWNCASE (casetab), | |
| 295 TRT_TABLE_OF (XCASE_TABLE_UPCASE (casetab), | |
| 296 XCHAR (val)))); | |
| 297 | |
| 298 return 0; | |
| 299 } | |
| 300 | |
| 301 static int | |
| 302 initialize_identity_mapper (struct chartab_range *range, | |
| 2286 | 303 Lisp_Object UNUSED (table), |
| 304 Lisp_Object UNUSED (val), void *arg) | |
| 826 | 305 { |
| 306 Lisp_Object trt = VOID_TO_LISP (arg); | |
| 307 if (range->type == CHARTAB_RANGE_CHAR) | |
| 308 SET_TRT_TABLE_OF (trt, range->ch, range->ch); | |
| 309 | |
| 310 return 0; | |
| 311 } | |
| 312 | |
| 313 static int | |
| 314 compute_up_or_eqv_mapper (struct chartab_range *range, | |
| 2286 | 315 Lisp_Object UNUSED (table), |
| 316 Lisp_Object val, void *arg) | |
| 826 | 317 { |
| 318 Lisp_Object inverse = VOID_TO_LISP (arg); | |
| 867 | 319 Ichar toch = XCHAR (val); |
| 826 | 320 |
| 321 if (range->type == CHARTAB_RANGE_CHAR && range->ch != toch) | |
| 322 { | |
| 867 | 323 Ichar c = TRT_TABLE_OF (inverse, toch); |
| 826 | 324 SET_TRT_TABLE_OF (inverse, toch, range->ch); |
| 325 SET_TRT_TABLE_OF (inverse, range->ch, c); | |
| 326 } | |
| 327 | |
| 328 return 0; | |
| 329 } | |
| 330 | |
| 331 /* Recomputing the canonical and equivalency tables from scratch is a | |
| 332 lengthy process, and doing them incrementally is extremely difficult or | |
| 333 perhaps impossible -- and certainly not worth it. To avoid lots of | |
| 334 excessive recomputation when lots of stuff is incrementally added, we | |
| 335 just store a dirty flag and then recompute when a value from the canon | |
| 336 or eqv tables is actually needed. */ | |
| 337 | |
| 338 void | |
| 339 recompute_case_table (Lisp_Object casetab) | |
| 340 { | |
| 341 struct chartab_range range; | |
| 342 | |
| 343 range.type = CHARTAB_RANGE_ALL; | |
| 344 /* Turn off dirty flag first so we don't get infinite recursion when | |
| 345 retrieving the values below! */ | |
| 346 XCASE_TABLE (casetab)->dirty = 0; | |
| 347 map_char_table (XCASE_TABLE_DOWNCASE (casetab), &range, | |
| 348 compute_canon_mapper, LISP_TO_VOID (casetab)); | |
| 349 map_char_table (XCASE_TABLE_CANON (casetab), &range, | |
| 350 initialize_identity_mapper, | |
| 351 LISP_TO_VOID (XCASE_TABLE_EQV (casetab))); | |
| 352 map_char_table (XCASE_TABLE_CANON (casetab), &range, | |
| 353 compute_up_or_eqv_mapper, | |
| 354 LISP_TO_VOID (XCASE_TABLE_EQV (casetab))); | |
| 355 } | |
| 356 | |
| 428 | 357 DEFUN ("current-case-table", Fcurrent_case_table, 0, 1, 0, /* |
| 358 Return the case table of BUFFER, which defaults to the current buffer. | |
| 359 */ | |
| 360 (buffer)) | |
| 361 { | |
| 362 struct buffer *buf = decode_buffer (buffer, 0); | |
| 363 | |
| 446 | 364 return buf->case_table; |
| 428 | 365 } |
| 366 | |
| 367 DEFUN ("standard-case-table", Fstandard_case_table, 0, 0, 0, /* | |
| 368 Return the standard case table. | |
| 369 This is the one used for new buffers. | |
| 370 */ | |
| 371 ()) | |
| 372 { | |
| 446 | 373 return Vstandard_case_table; |
| 428 | 374 } |
| 375 | |
| 826 | 376 static void |
| 377 convert_old_style_syntax_string (Lisp_Object table, Lisp_Object string) | |
| 378 { | |
| 867 | 379 Ichar i; |
| 826 | 380 |
| 381 for (i = 0; i < 256; i++) | |
| 867 | 382 SET_TRT_TABLE_OF (table, i, string_ichar (string, i)); |
| 826 | 383 } |
| 384 | |
| 385 static Lisp_Object | |
| 386 set_case_table (Lisp_Object table, int standard) | |
| 387 { | |
| 388 /* This function can GC */ | |
| 389 struct buffer *buf = | |
| 390 standard ? XBUFFER (Vbuffer_defaults) : current_buffer; | |
| 391 | |
| 392 check_case_table (table); | |
| 393 | |
| 394 if (CASE_TABLEP (table)) | |
| 395 { | |
| 396 if (standard) | |
| 397 Vstandard_case_table = table; | |
| 398 | |
| 399 buf->case_table = table; | |
| 400 } | |
| 401 else | |
| 402 { | |
| 403 /* For backward compatibility. */ | |
| 404 Lisp_Object down, up, canon, eqv, tail = table; | |
| 405 Lisp_Object casetab = | |
| 406 standard ? Vstandard_case_table : buf->case_table; | |
| 407 struct chartab_range range; | |
| 408 | |
| 409 range.type = CHARTAB_RANGE_ALL; | |
| 410 | |
| 411 Freset_char_table (XCASE_TABLE_DOWNCASE (casetab)); | |
| 412 Freset_char_table (XCASE_TABLE_UPCASE (casetab)); | |
| 413 Freset_char_table (XCASE_TABLE_CANON (casetab)); | |
| 414 Freset_char_table (XCASE_TABLE_EQV (casetab)); | |
| 415 | |
| 416 down = XCAR (tail); tail = XCDR (tail); | |
| 417 up = XCAR (tail); tail = XCDR (tail); | |
| 418 canon = XCAR (tail); tail = XCDR (tail); | |
| 419 eqv = XCAR (tail); | |
| 420 | |
| 421 convert_old_style_syntax_string (XCASE_TABLE_DOWNCASE (casetab), down); | |
| 422 | |
| 423 if (NILP (up)) | |
| 424 { | |
| 425 map_char_table (XCASE_TABLE_DOWNCASE (casetab), &range, | |
| 426 initialize_identity_mapper, | |
| 427 LISP_TO_VOID (XCASE_TABLE_UPCASE (casetab))); | |
| 428 map_char_table (XCASE_TABLE_DOWNCASE (casetab), &range, | |
| 429 compute_up_or_eqv_mapper, | |
| 430 LISP_TO_VOID (XCASE_TABLE_UPCASE (casetab))); | |
| 431 } | |
| 432 else | |
| 433 convert_old_style_syntax_string (XCASE_TABLE_UPCASE (casetab), up); | |
| 434 | |
| 435 if (NILP (canon)) | |
| 436 map_char_table (XCASE_TABLE_DOWNCASE (casetab), &range, | |
| 437 compute_canon_mapper, LISP_TO_VOID (casetab)); | |
| 438 else | |
| 439 convert_old_style_syntax_string (XCASE_TABLE_CANON (casetab), canon); | |
| 440 | |
| 441 if (NILP (eqv)) | |
| 442 { | |
| 443 map_char_table (XCASE_TABLE_CANON (casetab), &range, | |
| 444 initialize_identity_mapper, | |
| 445 LISP_TO_VOID (XCASE_TABLE_EQV (casetab))); | |
| 446 map_char_table (XCASE_TABLE_CANON (casetab), &range, | |
| 447 compute_up_or_eqv_mapper, | |
| 448 LISP_TO_VOID (XCASE_TABLE_EQV (casetab))); | |
| 449 } | |
| 450 else | |
| 451 convert_old_style_syntax_string (XCASE_TABLE_CANON (casetab), eqv); | |
| 452 } | |
| 453 | |
| 454 return buf->case_table; | |
| 455 } | |
| 428 | 456 |
| 457 DEFUN ("set-case-table", Fset_case_table, 1, 1, 0, /* | |
| 444 | 458 Select CASE-TABLE as the new case table for the current buffer. |
| 446 | 459 A case table is a case-table object or list |
| 460 (DOWNCASE UPCASE CANONICALIZE EQUIVALENCES) | |
| 428 | 461 where each element is either nil or a string of length 256. |
| 446 | 462 The latter is provided for backward-compatibility. |
| 428 | 463 DOWNCASE maps each character to its lower-case equivalent. |
| 464 UPCASE maps each character to its upper-case equivalent; | |
| 465 if lower and upper case characters are in 1-1 correspondence, | |
| 466 you may use nil and the upcase table will be deduced from DOWNCASE. | |
| 467 CANONICALIZE maps each character to a canonical equivalent; | |
| 468 any two characters that are related by case-conversion have the same | |
| 469 canonical equivalent character; it may be nil, in which case it is | |
| 470 deduced from DOWNCASE and UPCASE. | |
| 471 EQUIVALENCES is a map that cyclicly permutes each equivalence class | |
| 472 (of characters with the same canonical equivalent); it may be nil, | |
| 473 in which case it is deduced from CANONICALIZE. | |
| 474 | |
| 446 | 475 See also `get-case-table', `put-case-table' and `put-case-table-pair'. |
| 428 | 476 */ |
| 444 | 477 (case_table)) |
| 428 | 478 { |
| 446 | 479 /* This function can GC */ |
| 444 | 480 return set_case_table (case_table, 0); |
| 428 | 481 } |
| 482 | |
| 483 DEFUN ("set-standard-case-table", Fset_standard_case_table, 1, 1, 0, /* | |
| 444 | 484 Select CASE-TABLE as the new standard case table for new buffers. |
| 428 | 485 See `set-case-table' for more info on case tables. |
| 486 */ | |
| 444 | 487 (case_table)) |
| 428 | 488 { |
| 446 | 489 /* This function can GC */ |
| 444 | 490 return set_case_table (case_table, 1); |
| 428 | 491 } |
| 492 | |
| 493 | |
| 494 void | |
| 495 syms_of_casetab (void) | |
| 496 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
497 INIT_LISP_OBJECT (case_table); |
| 446 | 498 |
| 563 | 499 DEFSYMBOL_MULTIWORD_PREDICATE (Qcase_tablep); |
| 500 DEFSYMBOL (Qdowncase); | |
| 501 DEFSYMBOL (Qupcase); | |
| 428 | 502 |
| 826 | 503 DEFSUBR (Fmake_case_table); |
| 428 | 504 DEFSUBR (Fcase_table_p); |
| 446 | 505 DEFSUBR (Fget_case_table); |
| 506 DEFSUBR (Fput_case_table); | |
| 507 DEFSUBR (Fput_case_table_pair); | |
| 428 | 508 DEFSUBR (Fcurrent_case_table); |
| 509 DEFSUBR (Fstandard_case_table); | |
| 446 | 510 DEFSUBR (Fcopy_case_table); |
| 428 | 511 DEFSUBR (Fset_case_table); |
| 512 DEFSUBR (Fset_standard_case_table); | |
| 513 } | |
| 514 | |
| 515 void | |
| 516 complex_vars_of_casetab (void) | |
| 517 { | |
| 867 | 518 REGISTER Ichar i; |
| 428 | 519 |
| 446 | 520 staticpro (&Vstandard_case_table); |
| 428 | 521 |
| 826 | 522 Vstandard_case_table = allocate_case_table (1); |
| 428 | 523 |
| 524 for (i = 0; i < 256; i++) | |
| 525 { | |
| 526 unsigned char lowered = tolower (i); | |
| 527 | |
| 826 | 528 SET_TRT_TABLE_OF (XCASE_TABLE_DOWNCASE (Vstandard_case_table), i, |
| 529 lowered); | |
| 428 | 530 } |
| 531 | |
| 532 for (i = 0; i < 256; i++) | |
| 533 { | |
| 534 unsigned char flipped = (isupper (i) ? tolower (i) | |
| 535 : (islower (i) ? toupper (i) : i)); | |
| 536 | |
| 826 | 537 SET_TRT_TABLE_OF (XCASE_TABLE_UPCASE (Vstandard_case_table), i, |
| 538 flipped); | |
| 428 | 539 } |
| 826 | 540 |
| 541 recompute_case_table (Vstandard_case_table); | |
| 428 | 542 } |