Mercurial > hg > xemacs-beta
annotate src/casetab.c @ 4949:018e13fdeaeb
compile-related functions added, for use in Unicode-internal ws
-------------------- ChangeLog entries follow: --------------------
lisp/ChangeLog addition:
2010-01-17 Ben Wing <ben@xemacs.org>
* bytecomp-runtime.el:
* bytecomp-runtime.el (error-unless-tests-match): New.
* bytecomp-runtime.el (byte-compile-file-being-compiled): New.
* bytecomp-runtime.el (compiled-if): New.
* bytecomp-runtime.el (compiled-when): New.
Add functions for dealing with conditional compilation of different code
depending on the presence or absence of features. Necessary for some
Mule code where code is run during compilation (macros or eval-when-compile)
but, depending on how the code is written, the code itself will crash
either with or without Unicode-internal.
compiled-if and compiled-when are the basic functions for conditional
compilation. They automatically trigger an error message upon file
loading if, at that time, the test expression that selected which code
to compile does not have the same value as at compile time.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Sun, 17 Jan 2010 04:52:48 -0600 |
| parents | a98ca4640147 |
| children | 276e07b3cc93 |
| 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) | |
| 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; | |
| 407 | |
| 408 check_case_table (table); | |
| 409 | |
| 410 if (CASE_TABLEP (table)) | |
| 411 { | |
| 412 if (standard) | |
| 413 Vstandard_case_table = table; | |
| 414 | |
| 415 buf->case_table = table; | |
| 416 } | |
| 417 else | |
| 418 { | |
| 419 /* For backward compatibility. */ | |
| 420 Lisp_Object down, up, canon, eqv, tail = table; | |
| 421 Lisp_Object casetab = | |
| 422 standard ? Vstandard_case_table : buf->case_table; | |
| 423 struct chartab_range range; | |
| 424 | |
| 425 range.type = CHARTAB_RANGE_ALL; | |
| 426 | |
| 427 Freset_char_table (XCASE_TABLE_DOWNCASE (casetab)); | |
| 428 Freset_char_table (XCASE_TABLE_UPCASE (casetab)); | |
| 429 Freset_char_table (XCASE_TABLE_CANON (casetab)); | |
| 430 Freset_char_table (XCASE_TABLE_EQV (casetab)); | |
| 431 | |
| 432 down = XCAR (tail); tail = XCDR (tail); | |
| 433 up = XCAR (tail); tail = XCDR (tail); | |
| 434 canon = XCAR (tail); tail = XCDR (tail); | |
| 435 eqv = XCAR (tail); | |
| 436 | |
| 437 convert_old_style_syntax_string (XCASE_TABLE_DOWNCASE (casetab), down); | |
| 438 | |
| 439 if (NILP (up)) | |
| 440 { | |
| 441 map_char_table (XCASE_TABLE_DOWNCASE (casetab), &range, | |
| 442 initialize_identity_mapper, | |
| 443 LISP_TO_VOID (XCASE_TABLE_UPCASE (casetab))); | |
| 444 map_char_table (XCASE_TABLE_DOWNCASE (casetab), &range, | |
| 445 compute_up_or_eqv_mapper, | |
| 446 LISP_TO_VOID (XCASE_TABLE_UPCASE (casetab))); | |
| 447 } | |
| 448 else | |
| 449 convert_old_style_syntax_string (XCASE_TABLE_UPCASE (casetab), up); | |
| 450 | |
| 451 if (NILP (canon)) | |
| 452 map_char_table (XCASE_TABLE_DOWNCASE (casetab), &range, | |
| 453 compute_canon_mapper, LISP_TO_VOID (casetab)); | |
| 454 else | |
| 455 convert_old_style_syntax_string (XCASE_TABLE_CANON (casetab), canon); | |
| 456 | |
| 457 if (NILP (eqv)) | |
| 458 { | |
| 459 map_char_table (XCASE_TABLE_CANON (casetab), &range, | |
| 460 initialize_identity_mapper, | |
| 461 LISP_TO_VOID (XCASE_TABLE_EQV (casetab))); | |
| 462 map_char_table (XCASE_TABLE_CANON (casetab), &range, | |
| 463 compute_up_or_eqv_mapper, | |
| 464 LISP_TO_VOID (XCASE_TABLE_EQV (casetab))); | |
| 465 } | |
| 466 else | |
| 467 convert_old_style_syntax_string (XCASE_TABLE_CANON (casetab), eqv); | |
| 468 } | |
| 469 | |
| 470 return buf->case_table; | |
| 471 } | |
| 428 | 472 |
| 473 DEFUN ("set-case-table", Fset_case_table, 1, 1, 0, /* | |
| 444 | 474 Select CASE-TABLE as the new case table for the current buffer. |
| 446 | 475 A case table is a case-table object or list |
| 476 (DOWNCASE UPCASE CANONICALIZE EQUIVALENCES) | |
| 428 | 477 where each element is either nil or a string of length 256. |
| 446 | 478 The latter is provided for backward-compatibility. |
| 428 | 479 DOWNCASE maps each character to its lower-case equivalent. |
| 480 UPCASE maps each character to its upper-case equivalent; | |
| 481 if lower and upper case characters are in 1-1 correspondence, | |
| 482 you may use nil and the upcase table will be deduced from DOWNCASE. | |
| 483 CANONICALIZE maps each character to a canonical equivalent; | |
| 484 any two characters that are related by case-conversion have the same | |
| 485 canonical equivalent character; it may be nil, in which case it is | |
| 486 deduced from DOWNCASE and UPCASE. | |
| 487 EQUIVALENCES is a map that cyclicly permutes each equivalence class | |
| 488 (of characters with the same canonical equivalent); it may be nil, | |
| 489 in which case it is deduced from CANONICALIZE. | |
| 490 | |
| 446 | 491 See also `get-case-table', `put-case-table' and `put-case-table-pair'. |
| 428 | 492 */ |
| 444 | 493 (case_table)) |
| 428 | 494 { |
| 446 | 495 /* This function can GC */ |
| 444 | 496 return set_case_table (case_table, 0); |
| 428 | 497 } |
| 498 | |
| 499 DEFUN ("set-standard-case-table", Fset_standard_case_table, 1, 1, 0, /* | |
| 444 | 500 Select CASE-TABLE as the new standard case table for new buffers. |
| 428 | 501 See `set-case-table' for more info on case tables. |
| 502 */ | |
| 444 | 503 (case_table)) |
| 428 | 504 { |
| 446 | 505 /* This function can GC */ |
| 444 | 506 return set_case_table (case_table, 1); |
| 428 | 507 } |
| 508 | |
| 509 | |
| 510 void | |
| 511 syms_of_casetab (void) | |
| 512 { | |
| 446 | 513 INIT_LRECORD_IMPLEMENTATION (case_table); |
| 514 | |
| 563 | 515 DEFSYMBOL_MULTIWORD_PREDICATE (Qcase_tablep); |
| 516 DEFSYMBOL (Qdowncase); | |
| 517 DEFSYMBOL (Qupcase); | |
| 428 | 518 |
| 826 | 519 DEFSUBR (Fmake_case_table); |
| 428 | 520 DEFSUBR (Fcase_table_p); |
| 446 | 521 DEFSUBR (Fget_case_table); |
| 522 DEFSUBR (Fput_case_table); | |
| 523 DEFSUBR (Fput_case_table_pair); | |
| 428 | 524 DEFSUBR (Fcurrent_case_table); |
| 525 DEFSUBR (Fstandard_case_table); | |
| 446 | 526 DEFSUBR (Fcopy_case_table); |
| 428 | 527 DEFSUBR (Fset_case_table); |
| 528 DEFSUBR (Fset_standard_case_table); | |
| 529 } | |
| 530 | |
| 531 void | |
| 532 complex_vars_of_casetab (void) | |
| 533 { | |
| 867 | 534 REGISTER Ichar i; |
| 428 | 535 |
| 446 | 536 staticpro (&Vstandard_case_table); |
| 428 | 537 |
| 826 | 538 Vstandard_case_table = allocate_case_table (1); |
| 428 | 539 |
| 540 for (i = 0; i < 256; i++) | |
| 541 { | |
| 542 unsigned char lowered = tolower (i); | |
| 543 | |
| 826 | 544 SET_TRT_TABLE_OF (XCASE_TABLE_DOWNCASE (Vstandard_case_table), i, |
| 545 lowered); | |
| 428 | 546 } |
| 547 | |
| 548 for (i = 0; i < 256; i++) | |
| 549 { | |
| 550 unsigned char flipped = (isupper (i) ? tolower (i) | |
| 551 : (islower (i) ? toupper (i) : i)); | |
| 552 | |
| 826 | 553 SET_TRT_TABLE_OF (XCASE_TABLE_UPCASE (Vstandard_case_table), i, |
| 554 flipped); | |
| 428 | 555 } |
| 826 | 556 |
| 557 recompute_case_table (Vstandard_case_table); | |
| 428 | 558 } |