cgit.sxemacs.org Git - sxemacs/blob - src/casetab.c

   1 /* SXEmacs routines to deal with case tables.
   2    Copyright (C) 1987, 1992, 1993, 1994 Free Software Foundation, Inc.
   3    Copyright (C) 1995 Sun Microsystems, Inc.
   4
   5 This file is part of SXEmacs
   6
   7 SXEmacs is free software: you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation, either version 3 of the License, or
  10 (at your option) any later version.
  11
  12 SXEmacs is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with this program.  If not, see <http://www.gnu.org/licenses/>. */
  19
  20
  21  /* Synched up with: FSF 19.28.  Between FSF 19.28 and 19.30, casetab.c
  22     was rewritten to use junky FSF char tables.  Meanwhile I rewrote it
  23     to use more logical char tables.  RMS also discards the "list of four
  24     tables" format and instead stuffs the other tables as "extra slots"
  25     in the downcase table.  I've kept the four-lists format for now. */
  26
  27 /* Written by Howard Gayle.  See some mythical and not-in-the-Emacs-
  28    distribution file chartab.c for details. */
  29
  30 /* Modified for Mule by Ben Wing. */
  31
  32 /* Case table consists of four char-table.  Those are for downcase,
  33    upcase, canonical and equivalent respectively.
  34
  35    It's entry is like this:
  36
  37    downcase:    a -> a, A -> a.
  38    upcase:      a -> A, A -> a.  (The latter is for NOCASEP.)
  39    canon:       a -> a, A -> a.
  40    eqv:         a -> A, A -> a.
  41 */
  42
  43 #include <config.h>
  44 #include "lisp.h"
  45 #include "buffer.h"
  46 #include "opaque.h"
  47 #include "chartab.h"
  48 #include "casetab.h"
  49
  50 Lisp_Object Qcase_tablep, Qdowncase, Qupcase;
  51 Lisp_Object Vstandard_case_table;
  52
  53 static void compute_trt_inverse(Lisp_Object trt, Lisp_Object inverse);
  54 Lisp_Object case_table_char(Lisp_Object ch, Lisp_Object table);
  55
  56 #define STRING256_P(obj) ((STRINGP (obj) && XSTRING_CHAR_LENGTH (obj) == 256))
  57
  58 static Lisp_Object mark_case_table(Lisp_Object obj)
  59 {
  60         Lisp_Case_Table *ct = XCASE_TABLE(obj);
  61
  62         mark_object(CASE_TABLE_DOWNCASE(ct));
  63         mark_object(CASE_TABLE_UPCASE(ct));
  64         mark_object(CASE_TABLE_CANON(ct));
  65         mark_object(CASE_TABLE_EQV(ct));
  66         return Qnil;
  67 }
  68
  69 static void
  70 print_case_table(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
  71 {
  72         Lisp_Case_Table *ct = XCASE_TABLE(obj);
  73         char buf[200];
  74         if (print_readably)
  75                 error("printing unreadable object #<case-table 0x%x",
  76                       ct->header.uid);
  77         write_c_string("#<case-table ", printcharfun);
  78         sprintf(buf, "0x%x>", ct->header.uid);
  79         write_c_string(buf, printcharfun);
  80 }
  81
  82 static const struct lrecord_description case_table_description[] = {
  83         {XD_LISP_OBJECT, offsetof(Lisp_Case_Table, downcase_table)},
  84         {XD_LISP_OBJECT, offsetof(Lisp_Case_Table, upcase_table)},
  85         {XD_LISP_OBJECT, offsetof(Lisp_Case_Table, case_canon_table)},
  86         {XD_LISP_OBJECT, offsetof(Lisp_Case_Table, case_eqv_table)},
  87         {XD_END}
  88 };
  89
  90 DEFINE_LRECORD_IMPLEMENTATION("case-table", case_table,
  91                               mark_case_table, print_case_table, 0,
  92                               0, 0, case_table_description, Lisp_Case_Table);
  93
  94 static Lisp_Object allocate_case_table(void)
  95 {
  96         Lisp_Object val;
  97         Lisp_Case_Table *ct =
  98             alloc_lcrecord_type(Lisp_Case_Table, &lrecord_case_table);
  99
 100         SET_CASE_TABLE_DOWNCASE(ct, Qnil);
 101         SET_CASE_TABLE_UPCASE(ct, Qnil);
 102         SET_CASE_TABLE_CANON(ct, Qnil);
 103         SET_CASE_TABLE_EQV(ct, Qnil);
 104
 105         XSETCASE_TABLE(val, ct);
 106         return val;
 107 }
 108
 109 DEFUN("case-table-p", Fcase_table_p, 1, 1, 0,   /*
 110 Return t if OBJECT is a case table.
 111 See `set-case-table' for more information on these data structures.
 112 */
 113       (object))
 114 {
 115         if (CASE_TABLEP(object))
 116                 return Qt;
 117         else {
 118                 Lisp_Object down, up, canon, eqv;
 119                 if (!CONSP(object))
 120                         return Qnil;
 121                 down = XCAR(object);
 122                 object = XCDR(object);
 123                 if (!CONSP(object))
 124                         return Qnil;
 125                 up = XCAR(object);
 126                 object = XCDR(object);
 127                 if (!CONSP(object))
 128                         return Qnil;
 129                 canon = XCAR(object);
 130                 object = XCDR(object);
 131                 if (!CONSP(object))
 132                         return Qnil;
 133                 eqv = XCAR(object);
 134
 135                 return ((STRING256_P(down)
 136                          && (NILP(up) || STRING256_P(up))
 137                          && ((NILP(canon) && NILP(eqv))
 138                              || STRING256_P(canon))
 139                          && (NILP(eqv) || STRING256_P(eqv)))
 140                         ? Qt : Qnil);
 141
 142         }
 143 }
 144
 145 static Lisp_Object check_case_table(Lisp_Object object)
 146 {
 147         /* This function can GC */
 148         while (NILP(Fcase_table_p(object)))
 149                 object = wrong_type_argument(Qcase_tablep, object);
 150         return object;
 151 }
 152
 153 Lisp_Object case_table_char(Lisp_Object ch, Lisp_Object table)
 154 {
 155         Lisp_Object ct_char;
 156         ct_char = get_char_table(XCHAR(ch), XCHAR_TABLE(table));
 157         if (NILP(ct_char))
 158                 return ch;
 159         else
 160                 return ct_char;
 161 }
 162
 163 DEFUN("get-case-table", Fget_case_table, 3, 3, 0,       /*
 164 Return CHAR-CASE version of CHARACTER in CASE-TABLE.
 165
 166 CHAR-CASE is either downcase or upcase.
 167 */
 168       (char_case, character, case_table))
 169 {
 170         CHECK_CHAR(character);
 171         CHECK_CASE_TABLE(case_table);
 172         if (EQ(char_case, Qdowncase))
 173                 return case_table_char(character,
 174                                        XCASE_TABLE_DOWNCASE(case_table));
 175         else if (EQ(char_case, Qupcase))
 176                 return case_table_char(character,
 177                                        XCASE_TABLE_UPCASE(case_table));
 178         else
 179                 signal_simple_error("Char case must be downcase or upcase",
 180                                     char_case);
 181
 182         return Qnil;            /* Not reached. */
 183 }
 184
 185 DEFUN("put-case-table", Fput_case_table, 4, 4, 0,       /*
 186 Set CHAR-CASE version of CHARACTER to be VALUE in CASE-TABLE.
 187
 188 CHAR-CASE is either downcase or upcase.
 189 See also `put-case-table-pair'.
 190 */
 191       (char_case, character, value, case_table))
 192 {
 193         CHECK_CHAR(character);
 194         CHECK_CHAR(value);
 195
 196         if (EQ(char_case, Qdowncase)) {
 197                 Fput_char_table(character, value,
 198                                 XCASE_TABLE_DOWNCASE(case_table));
 199                 /* This one is not at all intuitive.  */
 200                 Fput_char_table(character, value,
 201                                 XCASE_TABLE_UPCASE(case_table));
 202                 Fput_char_table(character, value,
 203                                 XCASE_TABLE_CANON(case_table));
 204                 Fput_char_table(value, value, XCASE_TABLE_CANON(case_table));
 205                 Fput_char_table(value, character, XCASE_TABLE_EQV(case_table));
 206                 Fput_char_table(character, value, XCASE_TABLE_EQV(case_table));
 207         } else if (EQ(char_case, Qupcase)) {
 208                 Fput_char_table(character, value,
 209                                 XCASE_TABLE_UPCASE(case_table));
 210                 Fput_char_table(character, character,
 211                                 XCASE_TABLE_DOWNCASE(case_table));
 212                 Fput_char_table(character, character,
 213                                 XCASE_TABLE_CANON(case_table));
 214                 Fput_char_table(value, character,
 215                                 XCASE_TABLE_CANON(case_table));
 216                 Fput_char_table(value, character, XCASE_TABLE_EQV(case_table));
 217                 Fput_char_table(character, value, XCASE_TABLE_EQV(case_table));
 218         } else
 219                 signal_simple_error("Char case must be downcase or upcase",
 220                                     char_case);
 221
 222         return Qnil;
 223 }
 224
 225 DEFUN("put-case-table-pair", Fput_case_table_pair, 3, 3, 0,     /*
 226 Make UC and LC a pair of inter-case-converting letters in CASE-TABLE.
 227 UC is an uppercase character and LC is a downcase character.
 228 */
 229       (uc, lc, case_table))
 230 {
 231         CHECK_CHAR(uc);
 232         CHECK_CHAR(lc);
 233         CHECK_CASE_TABLE(case_table);
 234
 235         Fput_char_table(lc, lc, XCASE_TABLE_DOWNCASE(case_table));
 236         Fput_char_table(uc, lc, XCASE_TABLE_UPCASE(case_table));
 237         Fput_char_table(uc, lc, XCASE_TABLE_DOWNCASE(case_table));
 238         Fput_char_table(lc, uc, XCASE_TABLE_UPCASE(case_table));
 239
 240         Fput_char_table(lc, lc, XCASE_TABLE_CANON(case_table));
 241         Fput_char_table(uc, lc, XCASE_TABLE_CANON(case_table));
 242         Fput_char_table(uc, lc, XCASE_TABLE_EQV(case_table));
 243         Fput_char_table(lc, uc, XCASE_TABLE_EQV(case_table));
 244         return Qnil;
 245 }
 246
 247 DEFUN("copy-case-table", Fcopy_case_table, 1, 1, 0,     /*
 248 Return a new case table which is a copy of CASE-TABLE
 249 */
 250       (case_table))
 251 {
 252         Lisp_Object new_obj;
 253         CHECK_CASE_TABLE(case_table);
 254
 255         new_obj = allocate_case_table();
 256         XSET_CASE_TABLE_DOWNCASE
 257             (new_obj, Fcopy_char_table(XCASE_TABLE_DOWNCASE(case_table)));
 258         XSET_CASE_TABLE_UPCASE
 259             (new_obj, Fcopy_char_table(XCASE_TABLE_UPCASE(case_table)));
 260         XSET_CASE_TABLE_CANON
 261             (new_obj, Fcopy_char_table(XCASE_TABLE_CANON(case_table)));
 262         XSET_CASE_TABLE_EQV
 263             (new_obj, Fcopy_char_table(XCASE_TABLE_EQV(case_table)));
 264         return new_obj;
 265 }
 266
 267 DEFUN("current-case-table", Fcurrent_case_table, 0, 1, 0,       /*
 268 Return the case table of BUFFER, which defaults to the current buffer.
 269 */
 270       (buffer))
 271 {
 272         struct buffer *buf = decode_buffer(buffer, 0);
 273
 274         return buf->case_table;
 275 }
 276
 277 DEFUN("standard-case-table", Fstandard_case_table, 0, 0, 0,     /*
 278 Return the standard case table.
 279 This is the one used for new buffers.
 280 */
 281       ())
 282 {
 283         return Vstandard_case_table;
 284 }
 285
 286 static Lisp_Object set_case_table(Lisp_Object table, int standard);
 287
 288 DEFUN("set-case-table", Fset_case_table, 1, 1, 0, /*
 289 Select CASE-TABLE as the new case table for the current buffer.
 290 A case table is a case-table object or list
 291 DOWNCASE UPCASE CANONICALIZE EQUIVALENCES
 292 where each element is either nil or a string of length 256.
 293 The latter is provided for backward-compatibility.
 294 DOWNCASE maps each character to its lower-case equivalent.
 295 UPCASE maps each character to its upper-case equivalent,
 296 if lower and upper case characters are in 1-1 correspondence,
 297 you may use nil and the upcase table will be deduced from DOWNCASE.
 298 CANONICALIZE maps each character to a canonical equivalent,
 299 any two characters that are related by case-conversion have the same
 300 canonical equivalent character, it may be nil, in which case it is
 301 deduced from DOWNCASE and UPCASE.
 302 EQUIVALENCES is a map that cyclicly permutes each equivalence class
 303 of characters with the same canonical equivalent it may be nil,
 304 in which case it is deduced from CANONICALIZE.
 305
 306 See also `get-case-table', `put-case-table' and `put-case-table-pair'.
 307 */
 308       (case_table))
 309 {
 310         /* This function can GC */
 311         return set_case_table(case_table, 0);
 312 }
 313
 314 DEFUN("set-standard-case-table", Fset_standard_case_table, 1, 1, 0,     /*
 315 Select CASE-TABLE as the new standard case table for new buffers.
 316 See `set-case-table' for more info on case tables.
 317 */
 318       (case_table))
 319 {
 320         /* This function can GC */
 321         return set_case_table(case_table, 1);
 322 }
 323
 324 static Lisp_Object set_case_table(Lisp_Object table, int standard)
 325 {
 326         /* This function can GC */
 327         struct buffer *buf =
 328             standard ? XBUFFER(Vbuffer_defaults) : current_buffer;
 329
 330         check_case_table(table);
 331
 332         if (CASE_TABLEP(table)) {
 333                 if (standard)
 334                         Vstandard_case_table = table;
 335
 336                 buf->case_table = table;
 337         } else {
 338                 /* For backward compatibility. */
 339                 Lisp_Object down, up, canon, eqv, tail = table;
 340                 Lisp_Object temp;
 341                 int i;
 342
 343                 down = XCAR(tail);
 344                 tail = XCDR(tail);
 345                 up = XCAR(tail);
 346                 tail = XCDR(tail);
 347                 canon = XCAR(tail);
 348                 tail = XCDR(tail);
 349                 eqv = XCAR(tail);
 350
 351                 temp = down;
 352                 down = MAKE_TRT_TABLE();
 353                 for (i = 0; i < 256; i++)
 354                         SET_TRT_TABLE_CHAR_1(down, i,
 355                                              string_char(XSTRING(temp), i));
 356
 357                 if (NILP(up)) {
 358                         up = MAKE_TRT_TABLE();
 359                         compute_trt_inverse(down, up);
 360                 } else {
 361                         temp = up;
 362                         up = MAKE_TRT_TABLE();
 363                         for (i = 0; i < 256; i++)
 364                                 SET_TRT_TABLE_CHAR_1(up, i,
 365                                                      string_char(XSTRING(temp),
 366                                                                  i));
 367                 }
 368                 if (NILP(canon)) {
 369                         canon = MAKE_TRT_TABLE();
 370
 371                         /* Set up the CANON table; for each character,
 372                            this sequence of upcasing and downcasing ought to
 373                            get the "preferred" lowercase equivalent.  */
 374                         for (i = 0; i < 256; i++)
 375                                 SET_TRT_TABLE_CHAR_1(canon, i,
 376                                                      TRT_TABLE_CHAR_1
 377                                                      (down,
 378                                                       TRT_TABLE_CHAR_1
 379                                                       (up,
 380                                                        TRT_TABLE_CHAR_1(down,
 381                                                                         i))));
 382                 } else {
 383                         temp = canon;
 384                         canon = MAKE_TRT_TABLE();
 385                         for (i = 0; i < 256; i++)
 386                                 SET_TRT_TABLE_CHAR_1(canon, i,
 387                                                      string_char(XSTRING(temp),
 388                                                                  i));
 389                 }
 390
 391                 if (NILP(eqv)) {
 392                         eqv = MAKE_TRT_TABLE();
 393                         compute_trt_inverse(canon, eqv);
 394                 } else {
 395                         temp = eqv;
 396                         eqv = MAKE_TRT_TABLE();
 397                         for (i = 0; i < 256; i++)
 398                                 SET_TRT_TABLE_CHAR_1(eqv, i,
 399                                                      string_char(XSTRING(temp),
 400                                                                  i));
 401                 }
 402
 403                 if (standard) {
 404                         XSET_CASE_TABLE_DOWNCASE(Vstandard_case_table, down);
 405                         XSET_CASE_TABLE_UPCASE(Vstandard_case_table, up);
 406                         XSET_CASE_TABLE_CANON(Vstandard_case_table, canon);
 407                         XSET_CASE_TABLE_EQV(Vstandard_case_table, eqv);
 408                 }
 409
 410                 buf->case_table = allocate_case_table();
 411                 XSET_CASE_TABLE_DOWNCASE(buf->case_table, down);
 412                 XSET_CASE_TABLE_UPCASE(buf->case_table, up);
 413                 XSET_CASE_TABLE_CANON(buf->case_table, canon);
 414                 XSET_CASE_TABLE_EQV(buf->case_table, eqv);
 415         }
 416
 417         return buf->case_table;
 418 }
 419 \f
 420 /* Given a translate table TRT, store the inverse mapping into INVERSE.
 421    Since TRT is not one-to-one, INVERSE is not a simple mapping.
 422    Instead, it divides the space of characters into equivalence classes.
 423    All characters in a given class form one circular list, chained through
 424    the elements of INVERSE.  */
 425
 426 static void compute_trt_inverse(Lisp_Object trt, Lisp_Object inverse)
 427 {
 428         Charcount i = 0400;
 429         Emchar c, q;
 430
 431         while (--i)
 432                 SET_TRT_TABLE_CHAR_1(inverse, i, (Emchar) i);
 433         i = 0400;
 434         while (--i) {
 435                 if ((q = TRT_TABLE_CHAR_1(trt, i)) != (Emchar) i) {
 436                         c = TRT_TABLE_CHAR_1(inverse, q);
 437                         SET_TRT_TABLE_CHAR_1(inverse, q, (Emchar) i);
 438                         SET_TRT_TABLE_CHAR_1(inverse, i, c);
 439                 }
 440         }
 441 }
 442 \f
 443 void syms_of_casetab(void)
 444 {
 445         INIT_LRECORD_IMPLEMENTATION(case_table);
 446
 447         defsymbol(&Qcase_tablep, "case-table-p");
 448         defsymbol(&Qdowncase, "downcase");
 449         defsymbol(&Qupcase, "upcase");
 450
 451         DEFSUBR(Fcase_table_p);
 452         DEFSUBR(Fget_case_table);
 453         DEFSUBR(Fput_case_table);
 454         DEFSUBR(Fput_case_table_pair);
 455         DEFSUBR(Fcurrent_case_table);
 456         DEFSUBR(Fstandard_case_table);
 457         DEFSUBR(Fcopy_case_table);
 458         DEFSUBR(Fset_case_table);
 459         DEFSUBR(Fset_standard_case_table);
 460 }
 461
 462 void complex_vars_of_casetab(void)
 463 {
 464         REGISTER Emchar i;
 465         Lisp_Object tem;
 466
 467         staticpro(&Vstandard_case_table);
 468
 469         Vstandard_case_table = allocate_case_table();
 470
 471         tem = MAKE_TRT_TABLE();
 472         XSET_CASE_TABLE_DOWNCASE(Vstandard_case_table, tem);
 473         XSET_CASE_TABLE_CANON(Vstandard_case_table, tem);
 474
 475         /* Under Mule, can't do set_string_char() until Vcharset_control_1
 476            and Vcharset_ascii are initialized. */
 477         for (i = 0; i < 256; i++) {
 478                 unsigned char lowered = tolower(i);
 479
 480                 SET_TRT_TABLE_CHAR_1(tem, i, lowered);
 481         }
 482
 483         tem = MAKE_TRT_TABLE();
 484         XSET_CASE_TABLE_UPCASE(Vstandard_case_table, tem);
 485         XSET_CASE_TABLE_EQV(Vstandard_case_table, tem);
 486
 487         for (i = 0; i < 256; i++) {
 488                 unsigned char flipped = (isupper(i) ? tolower(i)
 489                                          : (islower(i) ? toupper(i) : i));
 490
 491                 SET_TRT_TABLE_CHAR_1(tem, i, flipped);
 492         }
 493 }