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         if (print_readably)
  74                 error("printing unreadable object #<case-table 0x%x",
  75                       ct->header.uid);
  76         write_fmt_str(printcharfun, "#<case-table 0x%x>", ct->header.uid);
  77 }
  78
  79 static const struct lrecord_description case_table_description[] = {
  80         {XD_LISP_OBJECT, offsetof(Lisp_Case_Table, downcase_table)},
  81         {XD_LISP_OBJECT, offsetof(Lisp_Case_Table, upcase_table)},
  82         {XD_LISP_OBJECT, offsetof(Lisp_Case_Table, case_canon_table)},
  83         {XD_LISP_OBJECT, offsetof(Lisp_Case_Table, case_eqv_table)},
  84         {XD_END}
  85 };
  86
  87 DEFINE_LRECORD_IMPLEMENTATION("case-table", case_table,
  88                               mark_case_table, print_case_table, 0,
  89                               0, 0, case_table_description, Lisp_Case_Table);
  90
  91 static Lisp_Object allocate_case_table(void)
  92 {
  93         Lisp_Object val;
  94         Lisp_Case_Table *ct =
  95             alloc_lcrecord_type(Lisp_Case_Table, &lrecord_case_table);
  96
  97         SET_CASE_TABLE_DOWNCASE(ct, Qnil);
  98         SET_CASE_TABLE_UPCASE(ct, Qnil);
  99         SET_CASE_TABLE_CANON(ct, Qnil);
 100         SET_CASE_TABLE_EQV(ct, Qnil);
 101
 102         XSETCASE_TABLE(val, ct);
 103         return val;
 104 }
 105
 106 DEFUN("case-table-p", Fcase_table_p, 1, 1, 0,   /*
 107 Return t if OBJECT is a case table.
 108 See `set-case-table' for more information on these data structures.
 109 */
 110       (object))
 111 {
 112         if (CASE_TABLEP(object))
 113                 return Qt;
 114         else {
 115                 Lisp_Object down, up, canon, eqv;
 116                 if (!CONSP(object))
 117                         return Qnil;
 118                 down = XCAR(object);
 119                 object = XCDR(object);
 120                 if (!CONSP(object))
 121                         return Qnil;
 122                 up = XCAR(object);
 123                 object = XCDR(object);
 124                 if (!CONSP(object))
 125                         return Qnil;
 126                 canon = XCAR(object);
 127                 object = XCDR(object);
 128                 if (!CONSP(object))
 129                         return Qnil;
 130                 eqv = XCAR(object);
 131
 132                 return ((STRING256_P(down)
 133                          && (NILP(up) || STRING256_P(up))
 134                          && ((NILP(canon) && NILP(eqv))
 135                              || STRING256_P(canon))
 136                          && (NILP(eqv) || STRING256_P(eqv)))
 137                         ? Qt : Qnil);
 138
 139         }
 140 }
 141
 142 static Lisp_Object check_case_table(Lisp_Object object)
 143 {
 144         /* This function can GC */
 145         while (NILP(Fcase_table_p(object)))
 146                 object = wrong_type_argument(Qcase_tablep, object);
 147         return object;
 148 }
 149
 150 Lisp_Object case_table_char(Lisp_Object ch, Lisp_Object table)
 151 {
 152         Lisp_Object ct_char;
 153         ct_char = get_char_table(XCHAR(ch), XCHAR_TABLE(table));
 154         if (NILP(ct_char))
 155                 return ch;
 156         else
 157                 return ct_char;
 158 }
 159
 160 DEFUN("get-case-table", Fget_case_table, 3, 3, 0,       /*
 161 Return CHAR-CASE version of CHARACTER in CASE-TABLE.
 162
 163 CHAR-CASE is either downcase or upcase.
 164 */
 165       (char_case, character, case_table))
 166 {
 167         CHECK_CHAR(character);
 168         CHECK_CASE_TABLE(case_table);
 169         if (EQ(char_case, Qdowncase))
 170                 return case_table_char(character,
 171                                        XCASE_TABLE_DOWNCASE(case_table));
 172         else if (EQ(char_case, Qupcase))
 173                 return case_table_char(character,
 174                                        XCASE_TABLE_UPCASE(case_table));
 175         else
 176                 signal_simple_error("Char case must be downcase or upcase",
 177                                     char_case);
 178
 179         return Qnil;            /* Not reached. */
 180 }
 181
 182 DEFUN("put-case-table", Fput_case_table, 4, 4, 0,       /*
 183 Set CHAR-CASE version of CHARACTER to be VALUE in CASE-TABLE.
 184
 185 CHAR-CASE is either downcase or upcase.
 186 See also `put-case-table-pair'.
 187 */
 188       (char_case, character, value, case_table))
 189 {
 190         CHECK_CHAR(character);
 191         CHECK_CHAR(value);
 192
 193         if (EQ(char_case, Qdowncase)) {
 194                 Fput_char_table(character, value,
 195                                 XCASE_TABLE_DOWNCASE(case_table));
 196                 /* This one is not at all intuitive.  */
 197                 Fput_char_table(character, value,
 198                                 XCASE_TABLE_UPCASE(case_table));
 199                 Fput_char_table(character, value,
 200                                 XCASE_TABLE_CANON(case_table));
 201                 Fput_char_table(value, value, XCASE_TABLE_CANON(case_table));
 202                 Fput_char_table(value, character, XCASE_TABLE_EQV(case_table));
 203                 Fput_char_table(character, value, XCASE_TABLE_EQV(case_table));
 204         } else if (EQ(char_case, Qupcase)) {
 205                 Fput_char_table(character, value,
 206                                 XCASE_TABLE_UPCASE(case_table));
 207                 Fput_char_table(character, character,
 208                                 XCASE_TABLE_DOWNCASE(case_table));
 209                 Fput_char_table(character, character,
 210                                 XCASE_TABLE_CANON(case_table));
 211                 Fput_char_table(value, character,
 212                                 XCASE_TABLE_CANON(case_table));
 213                 Fput_char_table(value, character, XCASE_TABLE_EQV(case_table));
 214                 Fput_char_table(character, value, XCASE_TABLE_EQV(case_table));
 215         } else
 216                 signal_simple_error("Char case must be downcase or upcase",
 217                                     char_case);
 218
 219         return Qnil;
 220 }
 221
 222 DEFUN("put-case-table-pair", Fput_case_table_pair, 3, 3, 0,     /*
 223 Make UC and LC a pair of inter-case-converting letters in CASE-TABLE.
 224 UC is an uppercase character and LC is a downcase character.
 225 */
 226       (uc, lc, case_table))
 227 {
 228         CHECK_CHAR(uc);
 229         CHECK_CHAR(lc);
 230         CHECK_CASE_TABLE(case_table);
 231
 232         Fput_char_table(lc, lc, XCASE_TABLE_DOWNCASE(case_table));
 233         Fput_char_table(uc, lc, XCASE_TABLE_UPCASE(case_table));
 234         Fput_char_table(uc, lc, XCASE_TABLE_DOWNCASE(case_table));
 235         Fput_char_table(lc, uc, XCASE_TABLE_UPCASE(case_table));
 236
 237         Fput_char_table(lc, lc, XCASE_TABLE_CANON(case_table));
 238         Fput_char_table(uc, lc, XCASE_TABLE_CANON(case_table));
 239         Fput_char_table(uc, lc, XCASE_TABLE_EQV(case_table));
 240         Fput_char_table(lc, uc, XCASE_TABLE_EQV(case_table));
 241         return Qnil;
 242 }
 243
 244 DEFUN("copy-case-table", Fcopy_case_table, 1, 1, 0,     /*
 245 Return a new case table which is a copy of CASE-TABLE
 246 */
 247       (case_table))
 248 {
 249         Lisp_Object new_obj;
 250         CHECK_CASE_TABLE(case_table);
 251
 252         new_obj = allocate_case_table();
 253         XSET_CASE_TABLE_DOWNCASE
 254             (new_obj, Fcopy_char_table(XCASE_TABLE_DOWNCASE(case_table)));
 255         XSET_CASE_TABLE_UPCASE
 256             (new_obj, Fcopy_char_table(XCASE_TABLE_UPCASE(case_table)));
 257         XSET_CASE_TABLE_CANON
 258             (new_obj, Fcopy_char_table(XCASE_TABLE_CANON(case_table)));
 259         XSET_CASE_TABLE_EQV
 260             (new_obj, Fcopy_char_table(XCASE_TABLE_EQV(case_table)));
 261         return new_obj;
 262 }
 263
 264 DEFUN("current-case-table", Fcurrent_case_table, 0, 1, 0,       /*
 265 Return the case table of BUFFER, which defaults to the current buffer.
 266 */
 267       (buffer))
 268 {
 269         struct buffer *buf = decode_buffer(buffer, 0);
 270
 271         return buf->case_table;
 272 }
 273
 274 DEFUN("standard-case-table", Fstandard_case_table, 0, 0, 0,     /*
 275 Return the standard case table.
 276 This is the one used for new buffers.
 277 */
 278       ())
 279 {
 280         return Vstandard_case_table;
 281 }
 282
 283 static Lisp_Object set_case_table(Lisp_Object table, int standard);
 284
 285 DEFUN("set-case-table", Fset_case_table, 1, 1, 0, /*
 286 Select CASE-TABLE as the new case table for the current buffer.
 287 A case table is a case-table object or list
 288 DOWNCASE UPCASE CANONICALIZE EQUIVALENCES
 289 where each element is either nil or a string of length 256.
 290 The latter is provided for backward-compatibility.
 291 DOWNCASE maps each character to its lower-case equivalent.
 292 UPCASE maps each character to its upper-case equivalent,
 293 if lower and upper case characters are in 1-1 correspondence,
 294 you may use nil and the upcase table will be deduced from DOWNCASE.
 295 CANONICALIZE maps each character to a canonical equivalent,
 296 any two characters that are related by case-conversion have the same
 297 canonical equivalent character, it may be nil, in which case it is
 298 deduced from DOWNCASE and UPCASE.
 299 EQUIVALENCES is a map that cyclicly permutes each equivalence class
 300 of characters with the same canonical equivalent it may be nil,
 301 in which case it is deduced from CANONICALIZE.
 302
 303 See also `get-case-table', `put-case-table' and `put-case-table-pair'.
 304 */
 305       (case_table))
 306 {
 307         /* This function can GC */
 308         return set_case_table(case_table, 0);
 309 }
 310
 311 DEFUN("set-standard-case-table", Fset_standard_case_table, 1, 1, 0,     /*
 312 Select CASE-TABLE as the new standard case table for new buffers.
 313 See `set-case-table' for more info on case tables.
 314 */
 315       (case_table))
 316 {
 317         /* This function can GC */
 318         return set_case_table(case_table, 1);
 319 }
 320
 321 static Lisp_Object set_case_table(Lisp_Object table, int standard)
 322 {
 323         /* This function can GC */
 324         struct buffer *buf =
 325             standard ? XBUFFER(Vbuffer_defaults) : current_buffer;
 326
 327         check_case_table(table);
 328
 329         if (CASE_TABLEP(table)) {
 330                 if (standard)
 331                         Vstandard_case_table = table;
 332
 333                 buf->case_table = table;
 334         } else {
 335                 /* For backward compatibility. */
 336                 Lisp_Object down, up, canon, eqv, tail = table;
 337                 Lisp_Object temp;
 338                 int i;
 339
 340                 down = XCAR(tail);
 341                 tail = XCDR(tail);
 342                 up = XCAR(tail);
 343                 tail = XCDR(tail);
 344                 canon = XCAR(tail);
 345                 tail = XCDR(tail);
 346                 eqv = XCAR(tail);
 347
 348                 temp = down;
 349                 down = MAKE_TRT_TABLE();
 350                 for (i = 0; i < 256; i++)
 351                         SET_TRT_TABLE_CHAR_1(down, i,
 352                                              string_char(XSTRING(temp), i));
 353
 354                 if (NILP(up)) {
 355                         up = MAKE_TRT_TABLE();
 356                         compute_trt_inverse(down, up);
 357                 } else {
 358                         temp = up;
 359                         up = MAKE_TRT_TABLE();
 360                         for (i = 0; i < 256; i++)
 361                                 SET_TRT_TABLE_CHAR_1(up, i,
 362                                                      string_char(XSTRING(temp),
 363                                                                  i));
 364                 }
 365                 if (NILP(canon)) {
 366                         canon = MAKE_TRT_TABLE();
 367
 368                         /* Set up the CANON table; for each character,
 369                            this sequence of upcasing and downcasing ought to
 370                            get the "preferred" lowercase equivalent.  */
 371                         for (i = 0; i < 256; i++)
 372                                 SET_TRT_TABLE_CHAR_1(canon, i,
 373                                                      TRT_TABLE_CHAR_1
 374                                                      (down,
 375                                                       TRT_TABLE_CHAR_1
 376                                                       (up,
 377                                                        TRT_TABLE_CHAR_1(down,
 378                                                                         i))));
 379                 } else {
 380                         temp = canon;
 381                         canon = MAKE_TRT_TABLE();
 382                         for (i = 0; i < 256; i++)
 383                                 SET_TRT_TABLE_CHAR_1(canon, i,
 384                                                      string_char(XSTRING(temp),
 385                                                                  i));
 386                 }
 387
 388                 if (NILP(eqv)) {
 389                         eqv = MAKE_TRT_TABLE();
 390                         compute_trt_inverse(canon, eqv);
 391                 } else {
 392                         temp = eqv;
 393                         eqv = MAKE_TRT_TABLE();
 394                         for (i = 0; i < 256; i++)
 395                                 SET_TRT_TABLE_CHAR_1(eqv, i,
 396                                                      string_char(XSTRING(temp),
 397                                                                  i));
 398                 }
 399
 400                 if (standard) {
 401                         XSET_CASE_TABLE_DOWNCASE(Vstandard_case_table, down);
 402                         XSET_CASE_TABLE_UPCASE(Vstandard_case_table, up);
 403                         XSET_CASE_TABLE_CANON(Vstandard_case_table, canon);
 404                         XSET_CASE_TABLE_EQV(Vstandard_case_table, eqv);
 405                 }
 406
 407                 buf->case_table = allocate_case_table();
 408                 XSET_CASE_TABLE_DOWNCASE(buf->case_table, down);
 409                 XSET_CASE_TABLE_UPCASE(buf->case_table, up);
 410                 XSET_CASE_TABLE_CANON(buf->case_table, canon);
 411                 XSET_CASE_TABLE_EQV(buf->case_table, eqv);
 412         }
 413
 414         return buf->case_table;
 415 }
 416 \f
 417 /* Given a translate table TRT, store the inverse mapping into INVERSE.
 418    Since TRT is not one-to-one, INVERSE is not a simple mapping.
 419    Instead, it divides the space of characters into equivalence classes.
 420    All characters in a given class form one circular list, chained through
 421    the elements of INVERSE.  */
 422
 423 static void compute_trt_inverse(Lisp_Object trt, Lisp_Object inverse)
 424 {
 425         Charcount i = 0400;
 426         Emchar c, q;
 427
 428         while (--i)
 429                 SET_TRT_TABLE_CHAR_1(inverse, i, (Emchar) i);
 430         i = 0400;
 431         while (--i) {
 432                 if ((q = TRT_TABLE_CHAR_1(trt, i)) != (Emchar) i) {
 433                         c = TRT_TABLE_CHAR_1(inverse, q);
 434                         SET_TRT_TABLE_CHAR_1(inverse, q, (Emchar) i);
 435                         SET_TRT_TABLE_CHAR_1(inverse, i, c);
 436                 }
 437         }
 438 }
 439 \f
 440 void syms_of_casetab(void)
 441 {
 442         INIT_LRECORD_IMPLEMENTATION(case_table);
 443
 444         defsymbol(&Qcase_tablep, "case-table-p");
 445         defsymbol(&Qdowncase, "downcase");
 446         defsymbol(&Qupcase, "upcase");
 447
 448         DEFSUBR(Fcase_table_p);
 449         DEFSUBR(Fget_case_table);
 450         DEFSUBR(Fput_case_table);
 451         DEFSUBR(Fput_case_table_pair);
 452         DEFSUBR(Fcurrent_case_table);
 453         DEFSUBR(Fstandard_case_table);
 454         DEFSUBR(Fcopy_case_table);
 455         DEFSUBR(Fset_case_table);
 456         DEFSUBR(Fset_standard_case_table);
 457 }
 458
 459 void complex_vars_of_casetab(void)
 460 {
 461         REGISTER Emchar i;
 462         Lisp_Object tem;
 463
 464         staticpro(&Vstandard_case_table);
 465
 466         Vstandard_case_table = allocate_case_table();
 467
 468         tem = MAKE_TRT_TABLE();
 469         XSET_CASE_TABLE_DOWNCASE(Vstandard_case_table, tem);
 470         XSET_CASE_TABLE_CANON(Vstandard_case_table, tem);
 471
 472         /* Under Mule, can't do set_string_char() until Vcharset_control_1
 473            and Vcharset_ascii are initialized. */
 474         for (i = 0; i < 256; i++) {
 475                 unsigned char lowered = tolower(i);
 476
 477                 SET_TRT_TABLE_CHAR_1(tem, i, lowered);
 478         }
 479
 480         tem = MAKE_TRT_TABLE();
 481         XSET_CASE_TABLE_UPCASE(Vstandard_case_table, tem);
 482         XSET_CASE_TABLE_EQV(Vstandard_case_table, tem);
 483
 484         for (i = 0; i < 256; i++) {
 485                 unsigned char flipped = (isupper(i) ? tolower(i)
 486                                          : (islower(i) ? toupper(i) : i));
 487
 488                 SET_TRT_TABLE_CHAR_1(tem, i, flipped);
 489         }
 490 }