Mercurial > hg > xemacs-beta
annotate src/casetab.c @ 5118:e0db3c197671 ben-lisp-object
merge up to latest default branch, doesn't compile yet
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Sat, 26 Dec 2009 21:18:49 -0600 |
| parents | 3742ea8250b5 4ee73bbe4f8e |
| children | b5df3737028a |
| 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 |
|
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 equivalence classe, 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) | |
| 826 | 108 printing_unreadable_object ("#<case-table 0x%x>", ct->header.uid); |
| 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 |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
125 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
|
126 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
|
127 0, 0, case_table_description, Lisp_Case_Table); |
| 446 | 128 |
| 129 static Lisp_Object | |
| 826 | 130 allocate_case_table (int init_tables) |
| 446 | 131 { |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
132 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
|
133 Lisp_Case_Table *ct = XCASE_TABLE (obj); |
| 446 | 134 |
| 826 | 135 if (init_tables) |
| 136 { | |
| 137 SET_CASE_TABLE_DOWNCASE (ct, MAKE_TRT_TABLE ()); | |
| 138 SET_CASE_TABLE_UPCASE (ct, MAKE_TRT_TABLE ()); | |
| 139 SET_CASE_TABLE_CANON (ct, MAKE_TRT_TABLE ()); | |
| 140 SET_CASE_TABLE_EQV (ct, MAKE_TRT_TABLE ()); | |
| 141 } | |
| 142 else | |
| 143 { | |
| 144 SET_CASE_TABLE_DOWNCASE (ct, Qnil); | |
| 145 SET_CASE_TABLE_UPCASE (ct, Qnil); | |
| 146 SET_CASE_TABLE_CANON (ct, Qnil); | |
| 147 SET_CASE_TABLE_EQV (ct, Qnil); | |
| 148 } | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
149 return obj; |
| 826 | 150 } |
| 446 | 151 |
| 826 | 152 DEFUN ("make-case-table", Fmake_case_table, 0, 0, 0, /* |
| 153 Create a new, empty case table. | |
| 154 */ | |
| 155 ()) | |
| 156 { | |
| 157 return allocate_case_table (1); | |
| 446 | 158 } |
| 428 | 159 |
| 160 DEFUN ("case-table-p", Fcase_table_p, 1, 1, 0, /* | |
| 444 | 161 Return t if OBJECT is a case table. |
| 428 | 162 See `set-case-table' for more information on these data structures. |
| 163 */ | |
| 444 | 164 (object)) |
| 428 | 165 { |
| 446 | 166 if (CASE_TABLEP (object)) |
| 167 return Qt; | |
| 168 else | |
| 169 { | |
| 170 Lisp_Object down, up, canon, eqv; | |
| 171 if (!CONSP (object)) | |
| 172 return Qnil; | |
| 173 down = XCAR (object); object = XCDR (object); | |
| 174 if (!CONSP (object)) | |
| 175 return Qnil; | |
| 176 up = XCAR (object); object = XCDR (object); | |
| 177 if (!CONSP (object)) | |
| 178 return Qnil; | |
| 179 canon = XCAR (object); object = XCDR (object); | |
| 180 if (!CONSP (object)) | |
| 181 return Qnil; | |
| 182 eqv = XCAR (object); | |
| 428 | 183 |
| 446 | 184 return ((STRING256_P (down) |
| 185 && (NILP (up) || STRING256_P (up)) | |
| 186 && ((NILP (canon) && NILP (eqv)) | |
| 187 || STRING256_P (canon)) | |
| 188 && (NILP (eqv) || STRING256_P (eqv))) | |
| 189 ? Qt : Qnil); | |
| 190 | |
| 191 } | |
| 428 | 192 } |
| 193 | |
| 194 static Lisp_Object | |
| 444 | 195 check_case_table (Lisp_Object object) |
| 428 | 196 { |
| 446 | 197 /* This function can GC */ |
| 444 | 198 while (NILP (Fcase_table_p (object))) |
| 199 object = wrong_type_argument (Qcase_tablep, object); | |
| 200 return object; | |
| 428 | 201 } |
| 202 | |
| 446 | 203 Lisp_Object |
| 204 case_table_char (Lisp_Object ch, Lisp_Object table) | |
| 205 { | |
| 206 Lisp_Object ct_char; | |
| 826 | 207 ct_char = get_char_table (XCHAR (ch), table); |
| 446 | 208 if (NILP (ct_char)) |
| 209 return ch; | |
| 210 else | |
| 211 return ct_char; | |
| 212 } | |
| 213 | |
| 214 DEFUN ("get-case-table", Fget_case_table, 3, 3, 0, /* | |
| 215 Return CHAR-CASE version of CHARACTER in CASE-TABLE. | |
| 216 | |
| 826 | 217 CHAR-CASE is either `downcase' or `upcase'. |
| 446 | 218 */ |
| 219 (char_case, character, case_table)) | |
| 220 { | |
| 221 CHECK_CHAR (character); | |
| 222 CHECK_CASE_TABLE (case_table); | |
| 223 if (EQ (char_case, Qdowncase)) | |
| 224 return case_table_char (character, XCASE_TABLE_DOWNCASE (case_table)); | |
| 225 else if (EQ (char_case, Qupcase)) | |
| 226 return case_table_char (character, XCASE_TABLE_UPCASE (case_table)); | |
| 227 else | |
| 563 | 228 invalid_constant ("Char case must be downcase or upcase", char_case); |
| 446 | 229 |
| 230 return Qnil; /* Not reached. */ | |
| 231 } | |
| 232 | |
| 233 DEFUN ("put-case-table", Fput_case_table, 4, 4, 0, /* | |
| 234 Set CHAR-CASE version of CHARACTER to be VALUE in CASE-TABLE. | |
| 235 | |
| 826 | 236 CHAR-CASE is either `downcase' or `upcase'. |
| 446 | 237 See also `put-case-table-pair'. |
| 238 */ | |
| 239 (char_case, character, value, case_table)) | |
| 240 { | |
| 241 CHECK_CHAR (character); | |
| 242 CHECK_CHAR (value); | |
| 243 | |
| 244 if (EQ (char_case, Qdowncase)) | |
| 245 { | |
| 246 Fput_char_table (character, value, XCASE_TABLE_DOWNCASE (case_table)); | |
| 826 | 247 /* This one is not at all intuitive. See comment at top of file. */ |
| 446 | 248 Fput_char_table (character, value, XCASE_TABLE_UPCASE (case_table)); |
| 249 } | |
| 250 else if (EQ (char_case, Qupcase)) | |
| 251 { | |
| 252 Fput_char_table (character, value, XCASE_TABLE_UPCASE (case_table)); | |
| 826 | 253 Fput_char_table (character, character, |
| 254 XCASE_TABLE_DOWNCASE (case_table)); | |
| 446 | 255 } |
| 256 else | |
| 826 | 257 invalid_constant ("CHAR-CASE must be downcase or upcase", char_case); |
| 446 | 258 |
| 826 | 259 XCASE_TABLE (case_table)->dirty = 1; |
| 446 | 260 return Qnil; |
| 261 } | |
| 262 | |
| 263 DEFUN ("put-case-table-pair", Fput_case_table_pair, 3, 3, 0, /* | |
| 264 Make UC and LC a pair of inter-case-converting letters in CASE-TABLE. | |
| 265 UC is an uppercase character and LC is a downcase character. | |
| 266 */ | |
| 267 (uc, lc, case_table)) | |
| 268 { | |
| 269 CHECK_CHAR (uc); | |
| 270 CHECK_CHAR (lc); | |
| 271 CHECK_CASE_TABLE (case_table); | |
| 272 | |
| 273 Fput_char_table (lc, lc, XCASE_TABLE_DOWNCASE (case_table)); | |
| 274 Fput_char_table (uc, lc, XCASE_TABLE_UPCASE (case_table)); | |
| 275 Fput_char_table (uc, lc, XCASE_TABLE_DOWNCASE (case_table)); | |
| 276 Fput_char_table (lc, uc, XCASE_TABLE_UPCASE (case_table)); | |
| 277 | |
| 826 | 278 XCASE_TABLE (case_table)->dirty = 1; |
| 446 | 279 return Qnil; |
| 280 } | |
| 281 | |
| 282 DEFUN ("copy-case-table", Fcopy_case_table, 1, 1, 0, /* | |
| 283 Return a new case table which is a copy of CASE-TABLE | |
| 284 */ | |
| 285 (case_table)) | |
| 286 { | |
| 287 Lisp_Object new_obj; | |
| 288 CHECK_CASE_TABLE (case_table); | |
| 289 | |
| 826 | 290 new_obj = allocate_case_table (0); |
| 446 | 291 XSET_CASE_TABLE_DOWNCASE |
| 292 (new_obj, Fcopy_char_table (XCASE_TABLE_DOWNCASE (case_table))); | |
| 293 XSET_CASE_TABLE_UPCASE | |
| 294 (new_obj, Fcopy_char_table (XCASE_TABLE_UPCASE (case_table))); | |
| 295 XSET_CASE_TABLE_CANON | |
| 296 (new_obj, Fcopy_char_table (XCASE_TABLE_CANON (case_table))); | |
| 297 XSET_CASE_TABLE_EQV | |
| 298 (new_obj, Fcopy_char_table (XCASE_TABLE_EQV (case_table))); | |
| 299 return new_obj; | |
| 300 } | |
| 301 | |
| 826 | 302 static int |
| 303 compute_canon_mapper (struct chartab_range *range, | |
| 2286 | 304 Lisp_Object UNUSED (table), Lisp_Object val, void *arg) |
| 826 | 305 { |
| 306 Lisp_Object casetab = VOID_TO_LISP (arg); | |
| 307 if (range->type == CHARTAB_RANGE_CHAR) | |
| 308 SET_TRT_TABLE_OF (XCASE_TABLE_CANON (casetab), range->ch, | |
| 309 TRT_TABLE_OF (XCASE_TABLE_DOWNCASE (casetab), | |
| 310 TRT_TABLE_OF (XCASE_TABLE_UPCASE (casetab), | |
| 311 XCHAR (val)))); | |
| 312 | |
| 313 return 0; | |
| 314 } | |
| 315 | |
| 316 static int | |
| 317 initialize_identity_mapper (struct chartab_range *range, | |
| 2286 | 318 Lisp_Object UNUSED (table), |
| 319 Lisp_Object UNUSED (val), void *arg) | |
| 826 | 320 { |
| 321 Lisp_Object trt = VOID_TO_LISP (arg); | |
| 322 if (range->type == CHARTAB_RANGE_CHAR) | |
| 323 SET_TRT_TABLE_OF (trt, range->ch, range->ch); | |
| 324 | |
| 325 return 0; | |
| 326 } | |
| 327 | |
| 328 static int | |
| 329 compute_up_or_eqv_mapper (struct chartab_range *range, | |
| 2286 | 330 Lisp_Object UNUSED (table), |
| 331 Lisp_Object val, void *arg) | |
| 826 | 332 { |
| 333 Lisp_Object inverse = VOID_TO_LISP (arg); | |
| 867 | 334 Ichar toch = XCHAR (val); |
| 826 | 335 |
| 336 if (range->type == CHARTAB_RANGE_CHAR && range->ch != toch) | |
| 337 { | |
| 867 | 338 Ichar c = TRT_TABLE_OF (inverse, toch); |
| 826 | 339 SET_TRT_TABLE_OF (inverse, toch, range->ch); |
| 340 SET_TRT_TABLE_OF (inverse, range->ch, c); | |
| 341 } | |
| 342 | |
| 343 return 0; | |
| 344 } | |
| 345 | |
| 346 /* Recomputing the canonical and equivalency tables from scratch is a | |
| 347 lengthy process, and doing them incrementally is extremely difficult or | |
| 348 perhaps impossible -- and certainly not worth it. To avoid lots of | |
| 349 excessive recomputation when lots of stuff is incrementally added, we | |
| 350 just store a dirty flag and then recompute when a value from the canon | |
| 351 or eqv tables is actually needed. */ | |
| 352 | |
| 353 void | |
| 354 recompute_case_table (Lisp_Object casetab) | |
| 355 { | |
| 356 struct chartab_range range; | |
| 357 | |
| 358 range.type = CHARTAB_RANGE_ALL; | |
| 359 /* Turn off dirty flag first so we don't get infinite recursion when | |
| 360 retrieving the values below! */ | |
| 361 XCASE_TABLE (casetab)->dirty = 0; | |
| 362 map_char_table (XCASE_TABLE_DOWNCASE (casetab), &range, | |
| 363 compute_canon_mapper, LISP_TO_VOID (casetab)); | |
| 364 map_char_table (XCASE_TABLE_CANON (casetab), &range, | |
| 365 initialize_identity_mapper, | |
| 366 LISP_TO_VOID (XCASE_TABLE_EQV (casetab))); | |
| 367 map_char_table (XCASE_TABLE_CANON (casetab), &range, | |
| 368 compute_up_or_eqv_mapper, | |
| 369 LISP_TO_VOID (XCASE_TABLE_EQV (casetab))); | |
| 370 } | |
| 371 | |
| 428 | 372 DEFUN ("current-case-table", Fcurrent_case_table, 0, 1, 0, /* |
| 373 Return the case table of BUFFER, which defaults to the current buffer. | |
| 374 */ | |
| 375 (buffer)) | |
| 376 { | |
| 377 struct buffer *buf = decode_buffer (buffer, 0); | |
| 378 | |
| 446 | 379 return buf->case_table; |
| 428 | 380 } |
| 381 | |
| 382 DEFUN ("standard-case-table", Fstandard_case_table, 0, 0, 0, /* | |
| 383 Return the standard case table. | |
| 384 This is the one used for new buffers. | |
| 385 */ | |
| 386 ()) | |
| 387 { | |
| 446 | 388 return Vstandard_case_table; |
| 428 | 389 } |
| 390 | |
| 826 | 391 static void |
| 392 convert_old_style_syntax_string (Lisp_Object table, Lisp_Object string) | |
| 393 { | |
| 867 | 394 Ichar i; |
| 826 | 395 |
| 396 for (i = 0; i < 256; i++) | |
| 867 | 397 SET_TRT_TABLE_OF (table, i, string_ichar (string, i)); |
| 826 | 398 } |
| 399 | |
| 400 static Lisp_Object | |
| 401 set_case_table (Lisp_Object table, int standard) | |
| 402 { | |
| 403 /* This function can GC */ | |
| 404 struct buffer *buf = | |
| 405 standard ? XBUFFER (Vbuffer_defaults) : current_buffer; | |
| 406 | |
| 407 check_case_table (table); | |
| 408 | |
| 409 if (CASE_TABLEP (table)) | |
| 410 { | |
| 411 if (standard) | |
| 412 Vstandard_case_table = table; | |
| 413 | |
| 414 buf->case_table = table; | |
| 415 } | |
| 416 else | |
| 417 { | |
| 418 /* For backward compatibility. */ | |
| 419 Lisp_Object down, up, canon, eqv, tail = table; | |
| 420 Lisp_Object casetab = | |
| 421 standard ? Vstandard_case_table : buf->case_table; | |
| 422 struct chartab_range range; | |
| 423 | |
| 424 range.type = CHARTAB_RANGE_ALL; | |
| 425 | |
| 426 Freset_char_table (XCASE_TABLE_DOWNCASE (casetab)); | |
| 427 Freset_char_table (XCASE_TABLE_UPCASE (casetab)); | |
| 428 Freset_char_table (XCASE_TABLE_CANON (casetab)); | |
| 429 Freset_char_table (XCASE_TABLE_EQV (casetab)); | |
| 430 | |
| 431 down = XCAR (tail); tail = XCDR (tail); | |
| 432 up = XCAR (tail); tail = XCDR (tail); | |
| 433 canon = XCAR (tail); tail = XCDR (tail); | |
| 434 eqv = XCAR (tail); | |
| 435 | |
| 436 convert_old_style_syntax_string (XCASE_TABLE_DOWNCASE (casetab), down); | |
| 437 | |
| 438 if (NILP (up)) | |
| 439 { | |
| 440 map_char_table (XCASE_TABLE_DOWNCASE (casetab), &range, | |
| 441 initialize_identity_mapper, | |
| 442 LISP_TO_VOID (XCASE_TABLE_UPCASE (casetab))); | |
| 443 map_char_table (XCASE_TABLE_DOWNCASE (casetab), &range, | |
| 444 compute_up_or_eqv_mapper, | |
| 445 LISP_TO_VOID (XCASE_TABLE_UPCASE (casetab))); | |
| 446 } | |
| 447 else | |
| 448 convert_old_style_syntax_string (XCASE_TABLE_UPCASE (casetab), up); | |
| 449 | |
| 450 if (NILP (canon)) | |
| 451 map_char_table (XCASE_TABLE_DOWNCASE (casetab), &range, | |
| 452 compute_canon_mapper, LISP_TO_VOID (casetab)); | |
| 453 else | |
| 454 convert_old_style_syntax_string (XCASE_TABLE_CANON (casetab), canon); | |
| 455 | |
| 456 if (NILP (eqv)) | |
| 457 { | |
| 458 map_char_table (XCASE_TABLE_CANON (casetab), &range, | |
| 459 initialize_identity_mapper, | |
| 460 LISP_TO_VOID (XCASE_TABLE_EQV (casetab))); | |
| 461 map_char_table (XCASE_TABLE_CANON (casetab), &range, | |
| 462 compute_up_or_eqv_mapper, | |
| 463 LISP_TO_VOID (XCASE_TABLE_EQV (casetab))); | |
| 464 } | |
| 465 else | |
| 466 convert_old_style_syntax_string (XCASE_TABLE_CANON (casetab), eqv); | |
| 467 } | |
| 468 | |
| 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 | |
| 509 void | |
| 510 syms_of_casetab (void) | |
| 511 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
512 INIT_LISP_OBJECT (case_table); |
| 446 | 513 |
| 563 | 514 DEFSYMBOL_MULTIWORD_PREDICATE (Qcase_tablep); |
| 515 DEFSYMBOL (Qdowncase); | |
| 516 DEFSYMBOL (Qupcase); | |
| 428 | 517 |
| 826 | 518 DEFSUBR (Fmake_case_table); |
| 428 | 519 DEFSUBR (Fcase_table_p); |
| 446 | 520 DEFSUBR (Fget_case_table); |
| 521 DEFSUBR (Fput_case_table); | |
| 522 DEFSUBR (Fput_case_table_pair); | |
| 428 | 523 DEFSUBR (Fcurrent_case_table); |
| 524 DEFSUBR (Fstandard_case_table); | |
| 446 | 525 DEFSUBR (Fcopy_case_table); |
| 428 | 526 DEFSUBR (Fset_case_table); |
| 527 DEFSUBR (Fset_standard_case_table); | |
| 528 } | |
| 529 | |
| 530 void | |
| 531 complex_vars_of_casetab (void) | |
| 532 { | |
| 867 | 533 REGISTER Ichar i; |
| 428 | 534 |
| 446 | 535 staticpro (&Vstandard_case_table); |
| 428 | 536 |
| 826 | 537 Vstandard_case_table = allocate_case_table (1); |
| 428 | 538 |
| 539 for (i = 0; i < 256; i++) | |
| 540 { | |
| 541 unsigned char lowered = tolower (i); | |
| 542 | |
| 826 | 543 SET_TRT_TABLE_OF (XCASE_TABLE_DOWNCASE (Vstandard_case_table), i, |
| 544 lowered); | |
| 428 | 545 } |
| 546 | |
| 547 for (i = 0; i < 256; i++) | |
| 548 { | |
| 549 unsigned char flipped = (isupper (i) ? tolower (i) | |
| 550 : (islower (i) ? toupper (i) : i)); | |
| 551 | |
| 826 | 552 SET_TRT_TABLE_OF (XCASE_TABLE_UPCASE (Vstandard_case_table), i, |
| 553 flipped); | |
| 428 | 554 } |
| 826 | 555 |
| 556 recompute_case_table (Vstandard_case_table); | |
| 428 | 557 } |